summaryrefslogtreecommitdiff
path: root/src/runtime
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime')
-rw-r--r--src/runtime/c/pgf/data.h5
-rw-r--r--src/runtime/c/pgf/parser.c92
-rw-r--r--src/runtime/c/pgf/pgf.c57
-rw-r--r--src/runtime/c/pgf/pgf.h5
-rw-r--r--src/runtime/c/pgf/printer.c2
-rw-r--r--src/runtime/c/pgf/reader.c8
-rw-r--r--src/runtime/c/utils/pgf-translate.c19
-rw-r--r--src/runtime/haskell/PGF.hs12
-rw-r--r--src/runtime/haskell/PGF/Binary.hs4
-rw-r--r--src/runtime/haskell/PGF/Data.hs8
-rw-r--r--src/runtime/haskell/PGF/Macros.hs4
-rw-r--r--src/runtime/haskell/PGF/Printer.hs4
-rw-r--r--src/runtime/haskell/PGF/Probabilistic.hs25
-rw-r--r--src/runtime/haskell/PGF/TypeCheck.hs8
14 files changed, 104 insertions, 149 deletions
diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h
index 5b0401764..9bc73dd0a 100644
--- a/src/runtime/c/pgf/data.h
+++ b/src/runtime/c/pgf/data.h
@@ -87,9 +87,7 @@ typedef struct {
PgfCId name;
PgfHypos* context;
- prob_t meta_prob;
- prob_t meta_token_prob;
- PgfMetaChildMap* meta_child_probs;
+ prob_t prob;
void* predicate;
} PgfAbsCat;
@@ -230,6 +228,7 @@ typedef GuSeq PgfCncFuns;
struct PgfConcr {
PgfCId name;
+ PgfAbstr* abstr;
PgfFlags* cflags;
PgfPrintNames* printnames;
GuMap* ccats;
diff --git a/src/runtime/c/pgf/parser.c b/src/runtime/c/pgf/parser.c
index 4e4724c75..ec21fc84e 100644
--- a/src/runtime/c/pgf/parser.c
+++ b/src/runtime/c/pgf/parser.c
@@ -63,7 +63,10 @@ typedef struct {
int prod_full_count;
#endif
PgfItem* free_item;
- prob_t beam_size;
+
+ prob_t heuristic_factor;
+ prob_t meta_prob;
+ prob_t meta_token_prob;
} PgfParsing;
typedef enum { BIND_NONE, BIND_HARD, BIND_SOFT } BIND_TYPE;
@@ -1389,12 +1392,14 @@ pgf_parsing_meta_predict(GuMapItor* fn, const void* key, void* value, GuExn* err
{
(void) (err);
- PgfAbsCat* abscat = (PgfAbsCat*) key;
- prob_t meta_prob = *((prob_t*) value);
+ PgfAbsCat* abscat = *((PgfAbsCat**) value);
PgfMetaPredictFn* clo = (PgfMetaPredictFn*) fn;
PgfParsing* ps = clo->ps;
PgfItem* meta_item = clo->meta_item;
+ if (abscat->prob == INFINITY)
+ return;
+
PgfCncCat* cnccat =
gu_map_get(ps->concr->cnccats, abscat->name, PgfCncCat*);
if (cnccat == NULL)
@@ -1412,7 +1417,7 @@ pgf_parsing_meta_predict(GuMapItor* fn, const void* key, void* value, GuExn* err
PgfItem* item =
pgf_item_copy(meta_item, ps);
item->inside_prob +=
- ccat->viterbi_prob+meta_prob;
+ ccat->viterbi_prob+abscat->prob;
size_t nargs = gu_seq_length(meta_item->args);
item->args = gu_new_seq(PgfPArg, nargs+1, ps->pool);
@@ -1698,18 +1703,14 @@ pgf_parsing_item(PgfParsing* ps, PgfItem* item)
}
pgf_parsing_complete(ps, item, ep);
} else {
- prob_t meta_token_prob =
- item->conts->ccat->cnccat->abscat->meta_token_prob;
+ prob_t meta_token_prob =
+ ps->meta_token_prob;
if (meta_token_prob != INFINITY) {
pgf_parsing_meta_scan(ps, item, meta_token_prob);
}
- PgfCIdMap* meta_child_probs =
- item->conts->ccat->cnccat->abscat->meta_child_probs;
- if (meta_child_probs != NULL) {
- PgfMetaPredictFn clo = { { pgf_parsing_meta_predict }, ps, item };
- gu_map_iter(meta_child_probs, &clo.fn, NULL);
- }
+ PgfMetaPredictFn clo = { { pgf_parsing_meta_predict }, ps, item };
+ gu_map_iter(ps->concr->abstr->cats, &clo.fn, NULL);
}
} else {
pgf_parsing_symbol(ps, item, item->curr_sym);
@@ -1721,22 +1722,38 @@ pgf_parsing_item(PgfParsing* ps, PgfItem* item)
}
}
-static prob_t
-pgf_parsing_default_beam_size(PgfConcr* concr)
+static void
+pgf_parsing_set_default_factors(PgfParsing* ps, PgfAbstr* abstr)
{
- PgfLiteral lit = gu_map_get(concr->cflags, "beam_size", PgfLiteral);
+ PgfLiteral lit;
- if (gu_variant_is_null(lit))
- return 0;
+ lit =
+ gu_map_get(abstr->aflags, "heuristic_search_factor", PgfLiteral);
+ if (!gu_variant_is_null(lit)) {
+ GuVariantInfo pi = gu_variant_open(lit);
+ gu_assert (pi.tag == PGF_LITERAL_FLT);
+ ps->heuristic_factor = ((PgfLiteralFlt*) pi.data)->val;
+ }
+
+ lit =
+ gu_map_get(abstr->aflags, "meta_prob", PgfLiteral);
+ if (!gu_variant_is_null(lit)) {
+ GuVariantInfo pi = gu_variant_open(lit);
+ gu_assert (pi.tag == PGF_LITERAL_FLT);
+ ps->meta_prob = - log(((PgfLiteralFlt*) pi.data)->val);
+ }
- GuVariantInfo pi = gu_variant_open(lit);
- gu_assert (pi.tag == PGF_LITERAL_FLT);
- return ((PgfLiteralFlt*) pi.data)->val;
+ lit =
+ gu_map_get(abstr->aflags, "meta_token_prob", PgfLiteral);
+ if (!gu_variant_is_null(lit)) {
+ GuVariantInfo pi = gu_variant_open(lit);
+ gu_assert (pi.tag == PGF_LITERAL_FLT);
+ ps->meta_token_prob = - log(((PgfLiteralFlt*) pi.data)->val);
+ }
}
static PgfParsing*
-pgf_new_parsing(PgfConcr* concr,
- GuString sentence, double heuristics,
+pgf_new_parsing(PgfConcr* concr, GuString sentence,
GuPool* pool, GuPool* out_pool)
{
PgfParsing* ps = gu_new(PgfParsing, pool);
@@ -1756,7 +1773,11 @@ pgf_new_parsing(PgfConcr* concr,
ps->prod_full_count = 0;
#endif
ps->free_item = NULL;
- ps->beam_size = heuristics;
+ ps->heuristic_factor = 0;
+ ps->meta_prob = INFINITY;
+ ps->meta_token_prob = INFINITY;
+
+ pgf_parsing_set_default_factors(ps, concr->abstr);
PgfExprMeta *expr_meta =
gu_new_variant(PGF_EXPR_META,
@@ -2107,7 +2128,7 @@ pgf_parse_result_is_new(PgfExprState* st)
// TODO: s/CId/Cat, add the cid to Cat, make Cat the key to CncCat
static PgfParsing*
pgf_parsing_init(PgfConcr* concr, PgfCId cat, size_t lin_idx,
- GuString sentence, double heuristics,
+ GuString sentence, double heuristic_factor,
GuExn* err,
GuPool* pool, GuPool* out_pool)
{
@@ -2121,12 +2142,13 @@ pgf_parsing_init(PgfConcr* concr, PgfCId cat, size_t lin_idx,
gu_assert(lin_idx < cnccat->n_lins);
- if (heuristics < 0) {
- heuristics = pgf_parsing_default_beam_size(concr);
+ PgfParsing* ps =
+ pgf_new_parsing(concr, sentence, pool, out_pool);
+
+ if (heuristic_factor >= 0) {
+ ps->heuristic_factor = heuristic_factor;
}
- PgfParsing* ps =
- pgf_new_parsing(concr, sentence, heuristics, pool, out_pool);
PgfParseState* state =
pgf_new_parse_state(ps, 0, BIND_SOFT);
@@ -2156,11 +2178,13 @@ pgf_parsing_init(PgfConcr* concr, PgfCId cat, size_t lin_idx,
gu_buf_heap_push(state->agenda, pgf_item_prob_order, &item);
}
- PgfItem *item =
- pgf_new_item(ps, conts, ps->meta_prod);
- item->inside_prob =
- ccat->cnccat->abscat->meta_prob;
- gu_buf_heap_push(state->agenda, pgf_item_prob_order, &item);
+ if (ps->meta_prob != INFINITY) {
+ PgfItem *item =
+ pgf_new_item(ps, conts, ps->meta_prod);
+ item->inside_prob =
+ ps->meta_prob;
+ gu_buf_heap_push(state->agenda, pgf_item_prob_order, &item);
+ }
}
}
@@ -2200,7 +2224,7 @@ pgf_parsing_proceed(PgfParsing* ps)
prob_t state_delta =
(st->viterbi_prob-(st->next ? st->next->viterbi_prob : 0))*
- ps->beam_size;
+ ps->heuristic_factor;
delta_prob += state_delta;
st = st->next;
}
diff --git a/src/runtime/c/pgf/pgf.c b/src/runtime/c/pgf/pgf.c
index e804f5ce7..93dea300a 100644
--- a/src/runtime/c/pgf/pgf.c
+++ b/src/runtime/c/pgf/pgf.c
@@ -35,63 +35,6 @@ pgf_read(const char* fpath,
return pgf;
}
-void
-pgf_load_meta_child_probs(PgfPGF* pgf, const char* fpath,
- GuPool* pool, GuExn* err)
-{
- FILE *fp = fopen(fpath, "r");
- if (!fp) {
- gu_raise_errno(err);
- return;
- }
-
- GuPool* tmp_pool = gu_new_pool();
-
- for (;;) {
- char cat1[21];
- char cat2[21];
- prob_t prob;
-
- if (fscanf(fp, "%20s\t%20s\t%f", cat1, cat2, &prob) < 3)
- break;
-
- prob = - log(prob);
-
- PgfAbsCat* abscat1 =
- gu_map_get(pgf->abstract.cats, cat1, PgfAbsCat*);
- if (abscat1 == NULL) {
- GuExnData* exn = gu_raise(err, PgfExn);
- exn->data = "Unknown category name";
- goto close;
- }
-
- if (strcmp(cat2, "*") == 0) {
- abscat1->meta_prob = prob;
- } else if (strcmp(cat2, "_") == 0) {
- abscat1->meta_token_prob = prob;
- } else {
- PgfAbsCat* abscat2 = gu_map_get(pgf->abstract.cats, cat2, PgfAbsCat*);
- if (abscat2 == NULL) {
- gu_raise(err, PgfExn);
- GuExnData* exn = gu_raise(err, PgfExn);
- exn->data = "Unknown category name";
- goto close;
- }
-
- if (abscat1->meta_child_probs == NULL) {
- abscat1->meta_child_probs =
- gu_map_type_new(PgfMetaChildMap, pool);
- }
-
- gu_map_put(abscat1->meta_child_probs, abscat2, prob_t, prob);
- }
- }
-
-close:
- gu_pool_free(tmp_pool);
- fclose(fp);
-}
-
GuString
pgf_abstract_name(PgfPGF* pgf)
{
diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h
index 61b8bea6c..ffc293306 100644
--- a/src/runtime/c/pgf/pgf.h
+++ b/src/runtime/c/pgf/pgf.h
@@ -80,11 +80,6 @@ pgf_read(const char* fpath,
*
*/
-
-void
-pgf_load_meta_child_probs(PgfPGF*, const char* fpath,
- GuPool* pool, GuExn* err);
-
GuString
pgf_abstract_name(PgfPGF*);
diff --git a/src/runtime/c/pgf/printer.c b/src/runtime/c/pgf/printer.c
index da7c70d7c..78c2b74db 100644
--- a/src/runtime/c/pgf/printer.c
+++ b/src/runtime/c/pgf/printer.c
@@ -48,7 +48,7 @@ pgf_print_cat(GuMapItor* fn, const void* key, void* value,
ctxt = next;
}
- gu_printf(out, err, " ; -- %f\n",cat->meta_prob);
+ gu_printf(out, err, " ; -- %f\n", cat->prob);
}
void
diff --git a/src/runtime/c/pgf/reader.c b/src/runtime/c/pgf/reader.c
index d215f25e1..12605b89a 100644
--- a/src/runtime/c/pgf/reader.c
+++ b/src/runtime/c/pgf/reader.c
@@ -516,10 +516,6 @@ pgf_read_abscat(PgfReader* rdr, PgfAbstr* abstr, PgfCIdMap* abscats)
gu_return_on_exn(rdr->err, NULL);
}
- abscat->meta_prob = INFINITY;
- abscat->meta_token_prob = INFINITY;
- abscat->meta_child_probs = NULL;
-
GuBuf* functions = gu_new_buf(PgfAbsFun*, rdr->tmp_pool);
size_t n_functions = pgf_read_len(rdr);
@@ -538,6 +534,8 @@ pgf_read_abscat(PgfReader* rdr, PgfAbstr* abstr, PgfCIdMap* abscats)
gu_buf_push(functions, PgfAbsFun*, absfun);
}
+ abscat->prob = - log(gu_in_f64be(rdr->in, rdr->err));
+
pgf_jit_predicate(rdr->jit_state, abscats, abscat, functions);
return abscat;
@@ -1155,6 +1153,8 @@ pgf_read_concrete(PgfReader* rdr, PgfAbstr* abstr, PgfAbsFun* abs_lin_fun)
pgf_read_cid(rdr, rdr->opool);
gu_return_on_exn(rdr->err, NULL);
+ concr->abstr = abstr;
+
concr->cflags =
pgf_read_flags(rdr);
gu_return_on_exn(rdr->err, NULL);
diff --git a/src/runtime/c/utils/pgf-translate.c b/src/runtime/c/utils/pgf-translate.c
index 79a4fdd42..32f8323ab 100644
--- a/src/runtime/c/utils/pgf-translate.c
+++ b/src/runtime/c/utils/pgf-translate.c
@@ -53,18 +53,17 @@ int main(int argc, char* argv[]) {
// Create the pool that is used to allocate everything
GuPool* pool = gu_new_pool();
int status = EXIT_SUCCESS;
- if (argc < 5 || argc > 6) {
- fprintf(stderr, "usage: %s pgf cat from-lang to-lang [probs-file]\n", argv[0]);
+ if (argc < 5) {
+ fprintf(stderr, "usage: %s pgf cat from-lang to-lang\n", argv[0]);
status = EXIT_FAILURE;
goto fail;
}
- char* filename = argv[1];
+ GuString filename = argv[1];
GuString cat = argv[2];
-
GuString from_lang = argv[3];
GuString to_lang = argv[4];
-
+
// Create an exception frame that catches all errors.
GuExn* err = gu_new_exn(NULL, gu_kind(type), pool);
@@ -78,16 +77,6 @@ int main(int argc, char* argv[]) {
goto fail;
}
- if (argc == 6) {
- char* meta_probs_filename = argv[5];
- pgf_load_meta_child_probs(pgf, meta_probs_filename, pool, err);
- if (!gu_ok(err)) {
- fprintf(stderr, "Loading meta child probs failed\n");
- status = EXIT_FAILURE;
- goto fail;
- }
- }
-
// Look up the source and destination concrete categories
PgfConcr* from_concr = pgf_get_language(pgf, from_lang);
PgfConcr* to_concr = pgf_get_language(pgf, to_lang);
diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs
index e7e5c53c5..0e3c79f40 100644
--- a/src/runtime/haskell/PGF.hs
+++ b/src/runtime/haskell/PGF.hs
@@ -292,8 +292,8 @@ categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))]
categoryContext pgf cat =
case Map.lookup cat (cats (abstract pgf)) of
- Just (hypos,_,_) -> Just hypos
- Nothing -> Nothing
+ Just (hypos,_,_,_) -> Just hypos
+ Nothing -> Nothing
startCat pgf = DTyp [] (lookStartCat pgf) []
@@ -301,8 +301,8 @@ functions pgf = Map.keys (funs (abstract pgf))
functionsByCat pgf cat =
case Map.lookup cat (cats (abstract pgf)) of
- Just (_,fns,_) -> map snd fns
- Nothing -> []
+ Just (_,fns,_,_) -> map snd fns
+ Nothing -> []
functionType pgf fun =
case Map.lookup fun (funs (abstract pgf)) of
@@ -325,8 +325,8 @@ browse pgf id = fmap (\def -> (def,producers,consumers)) definition
in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs])
Just (ty,_,Nothing, _,_) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty)
Nothing -> case Map.lookup id (cats (abstract pgf)) of
- Just (hyps,_,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)))
- Nothing -> Nothing
+ Just (hyps,_,_,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)))
+ Nothing -> Nothing
(producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf))
where
diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index 202939f04..2debcf12d 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -40,13 +40,13 @@ instance Binary CId where
instance Binary Abstr where
put abs = put (aflags abs,
fmap (\(w,x,y,z,_) -> (w,x,y,z)) (funs abs),
- fmap (\(x,y,_) -> (x,y)) (cats abs))
+ fmap (\(x,y,z,_) -> (x,y,z)) (cats abs))
get = do aflags <- get
funs <- get
cats <- get
return (Abstr{ aflags=aflags
, funs=fmap (\(w,x,y,z) -> (w,x,y,z,0)) funs
- , cats=fmap (\(x,y) -> (x,y,0)) cats
+ , cats=fmap (\(x,y,z) -> (x,y,z,0)) cats
, code=BS.empty
})
diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs
index e37b243d0..f5797739f 100644
--- a/src/runtime/haskell/PGF/Data.hs
+++ b/src/runtime/haskell/PGF/Data.hs
@@ -29,10 +29,10 @@ data PGF = PGF {
data Abstr = Abstr {
aflags :: Map.Map CId Literal, -- ^ value of a flag
funs :: Map.Map CId (Type,Int,Maybe [Equation],Double,BCAddr), -- ^ type, arrity and definition of function + probability
- cats :: Map.Map CId ([Hypo],[(Double, CId)],BCAddr), -- ^ 1. context of a category
- -- ^ 2. functions of a category. The order in the list is important,
- -- this is the order in which the type singatures are given in the source.
- -- The termination of the exhaustive generation might depend on this.
+ cats :: Map.Map CId ([Hypo],[(Double, CId)],Double,BCAddr), -- ^ 1. context of a category
+ -- 2. functions of a category. The functions are stored
+ -- in decreasing probability order.
+ -- 3. probability
code :: BS.ByteString
}
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs
index 830a16674..ce75b1c91 100644
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/src/runtime/haskell/PGF/Macros.hs
@@ -67,7 +67,7 @@ functionsToCat :: PGF -> CId -> [(CId,Type)]
functionsToCat pgf cat =
[(f,ty) | (_,f) <- fs, Just (ty,_,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]]
where
- (_,fs,_) = lookMap ([],[],0) cat $ cats $ abstract pgf
+ (_,fs,_,_) = lookMap ([],[],0,0) cat $ cats $ abstract pgf
-- | List of functions that lack linearizations in the given language.
missingLins :: PGF -> Language -> [CId]
@@ -82,7 +82,7 @@ restrictPGF :: (CId -> Bool) -> PGF -> PGF
restrictPGF cond pgf = pgf {
abstract = abstr {
funs = Map.filterWithKey (\c _ -> cond c) (funs abstr),
- cats = Map.map (\(hyps,fs,addr) -> (hyps,filter (cond . snd) fs,addr)) (cats abstr)
+ cats = Map.map (\(hyps,fs,p,addr) -> (hyps,filter (cond . snd) fs,p,addr)) (cats abstr)
}
} ---- restrict concrs also, might be needed
where
diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs
index 66d8530f0..d3a5ea1d9 100644
--- a/src/runtime/haskell/PGF/Printer.hs
+++ b/src/runtime/haskell/PGF/Printer.hs
@@ -26,8 +26,8 @@ ppAbs name a = text "abstract" <+> ppCId name <+> char '{' $$
ppFlag :: CId -> Literal -> Doc
ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+> char ';'
-ppCat :: CId -> ([Hypo],[(Double,CId)],BCAddr) -> Doc
-ppCat c (hyps,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
+ppCat :: CId -> ([Hypo],[(Double,CId)],Double,BCAddr) -> Doc
+ppCat c (hyps,_,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
ppFun :: CId -> (Type,Int,Maybe [Equation],Double,BCAddr) -> Doc
ppFun f (t,_,Just eqs,_,_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
diff --git a/src/runtime/haskell/PGF/Probabilistic.hs b/src/runtime/haskell/PGF/Probabilistic.hs
index 7f980254b..095ade022 100644
--- a/src/runtime/haskell/PGF/Probabilistic.hs
+++ b/src/runtime/haskell/PGF/Probabilistic.hs
@@ -24,13 +24,14 @@ import Data.Maybe (fromMaybe) --, fromJust
-- the probabilities for the different functions in a grammar.
data Probabilities = Probs {
funProbs :: Map.Map CId Double,
- catProbs :: Map.Map CId [(Double, CId)]
+ catProbs :: Map.Map CId (Double, [(Double, CId)])
}
-- | Renders the probability structure as string
showProbabilities :: Probabilities -> String
-showProbabilities = unlines . map pr . Map.toList . funProbs where
- pr (f,d) = showCId f ++ "\t" ++ show d
+showProbabilities = unlines . concatMap prProb . Map.toList . catProbs where
+ prProb (c,(p,fns)) = pr (p,c) : map pr fns
+ pr (p,f) = showCId f ++ "\t" ++ show p
-- | Reads the probabilities from a file.
-- This should be a text file where on every line
@@ -50,8 +51,12 @@ readProbabilitiesFromFile file pgf = do
-- for the result category.
mkProbabilities :: PGF -> Map.Map CId Double -> Probabilities
mkProbabilities pgf probs =
- let funs1 = Map.fromList [(f,p) | (_,cf) <- Map.toList cats1, (p,f) <- cf]
- cats1 = Map.map (\(_,fs,_) -> sortBy cmpProb (fill fs)) (cats (abstract pgf))
+ let funs1 = Map.fromList [(f,p) | (_,(_,fns)) <- Map.toList cats1, (p,f) <- fns]
+ cats1 = Map.mapWithKey (\c (_,fns,_,_) ->
+ let p' = fromMaybe 0 (Map.lookup c probs)
+ fns' = sortBy cmpProb (fill fns)
+ in (p', fns'))
+ (cats (abstract pgf))
in Probs funs1 cats1
where
cmpProb (p1,_) (p2,_) = compare p2 p1
@@ -71,15 +76,15 @@ defaultProbabilities pgf = mkProbabilities pgf Map.empty
getProbabilities :: PGF -> Probabilities
getProbabilities pgf = Probs {
- funProbs = Map.map (\(_,_,_,p,_) -> p) (funs (abstract pgf)),
- catProbs = Map.map (\(_,fns,_) -> fns) (cats (abstract pgf))
+ funProbs = Map.map (\(_,_,_,p,_) -> p ) (funs (abstract pgf)),
+ catProbs = Map.map (\(_,fns,p,_) -> (p,fns)) (cats (abstract pgf))
}
setProbabilities :: Probabilities -> PGF -> PGF
setProbabilities probs pgf = pgf {
abstract = (abstract pgf) {
- funs = mapUnionWith (\(ty,a,df,_,addr) p -> (ty,a,df,p,addr)) (funs (abstract pgf)) (funProbs probs),
- cats = mapUnionWith (\(hypos,_,addr) fns -> (hypos,fns,addr)) (cats (abstract pgf)) (catProbs probs)
+ funs = mapUnionWith (\(ty,a,df,_,addr) p -> (ty,a,df, p,addr)) (funs (abstract pgf)) (funProbs probs),
+ cats = mapUnionWith (\(hypos,_,_,addr) (p,fns) -> (hypos,fns,p,addr)) (cats (abstract pgf)) (catProbs probs)
}}
where
mapUnionWith f map1 map2 =
@@ -102,7 +107,7 @@ rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p)
mkProbDefs :: PGF -> ([[CId]],[(CId,Type,[Equation])])
mkProbDefs pgf =
- let cs = [(c,hyps,fns) | (c,(hyps0,fs,_)) <- Map.toList (cats (abstract pgf)),
+ let cs = [(c,hyps,fns) | (c,(hyps0,fs,_,_)) <- Map.toList (cats (abstract pgf)),
not (elem c [cidString,cidInt,cidFloat]),
let hyps = zipWith (\(bt,_,ty) n -> (bt,mkCId ('v':show n),ty))
hyps0
diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs
index 141189193..e582f97af 100644
--- a/src/runtime/haskell/PGF/TypeCheck.hs
+++ b/src/runtime/haskell/PGF/TypeCheck.hs
@@ -121,8 +121,8 @@ runTcM abstr f ms s = unTcM f abstr (\x ms s cp b -> let (es,xs) = cp b
lookupCatHyps :: CId -> TcM s [Hypo]
lookupCatHyps cat = TcM (\abstr k h ms -> case Map.lookup cat (cats abstr) of
- Just (hyps,_,_) -> k hyps ms
- Nothing -> h (UnknownCat cat))
+ Just (hyps,_,_,_) -> k hyps ms
+ Nothing -> h (UnknownCat cat))
lookupFunType :: CId -> TcM s Type
lookupFunType fun = TcM (\abstr k h ms -> case Map.lookup fun (funs abstr) of
@@ -143,8 +143,8 @@ typeGenerators scope cat = fmap normalize (liftM2 (++) x y)
| cat == cidString = return [(1.0,ELit (LStr "Foo"),TTyp [] (DTyp [] cat []))]
| otherwise = TcM (\abstr k h ms ->
case Map.lookup cat (cats abstr) of
- Just (_,fns,_) -> unTcM (mapM helper fns) abstr k h ms
- Nothing -> h (UnknownCat cat))
+ Just (_,fns,_,_) -> unTcM (mapM helper fns) abstr k h ms
+ Nothing -> h (UnknownCat cat))
helper (p,fn) = do
ty <- lookupFunType fn
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 08:03:15 +0000