summaryrefslogtreecommitdiff
path: root/src/runtime
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime')
-rw-r--r--src/runtime/c/pgf/expr.c51
-rw-r--r--src/runtime/c/pgf/expr.h7
-rw-r--r--src/runtime/haskell-bind/PGF2.hsc44
-rw-r--r--src/runtime/haskell-bind/PGF2/FFI.hs6
-rw-r--r--src/runtime/haskell-bind/PGF2/Type.hsc2
5 files changed, 99 insertions, 11 deletions
diff --git a/src/runtime/c/pgf/expr.c b/src/runtime/c/pgf/expr.c
index 8fee28fb9..4e9f5ca89 100644
--- a/src/runtime/c/pgf/expr.c
+++ b/src/runtime/c/pgf/expr.c
@@ -1,11 +1,12 @@
#include "pgf.h"
+#include "data.h"
#include <gu/assert.h>
#include <gu/utf8.h>
#include <gu/seq.h>
#include <ctype.h>
#include <stdio.h>
#include <stdlib.h>
-
+#include <math.h>
static PgfExpr
pgf_expr_unwrap(PgfExpr expr)
@@ -1466,6 +1467,30 @@ pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt,
gu_putc('>', out, err);
}
+PGF_API_DECL void
+pgf_print_category(PgfPGF *gr, PgfCId catname,
+ GuOut* out, GuExn *err)
+{
+ PgfAbsCat* abscat =
+ gu_seq_binsearch(gr->abstract.cats, pgf_abscat_order, PgfAbsCat, catname);
+ if (abscat == NULL) {
+ GuExnData* exn = gu_raise(err, PgfExn);
+ exn->data = "Unknown category";
+ return;
+ }
+
+ gu_puts(abscat->name, out, err);
+
+ PgfPrintContext* ctxt = NULL;
+ size_t n_hypos = gu_seq_length(abscat->context);
+ for (size_t i = 0; i < n_hypos; i++) {
+ PgfHypo *hypo = gu_seq_index(abscat->context, PgfHypo, i);
+
+ gu_putc(' ', out, err);
+ ctxt = pgf_print_hypo(hypo, ctxt, 4, out, err);
+ }
+}
+
PGF_API bool
pgf_type_eq(PgfType* t1, PgfType* t2)
{
@@ -1500,3 +1525,27 @@ pgf_type_eq(PgfType* t1, PgfType* t2)
return true;
}
+
+PGF_API prob_t
+pgf_compute_tree_probability(PgfPGF *gr, PgfExpr expr)
+{
+ GuVariantInfo ei = gu_variant_open(expr);
+ switch (ei.tag) {
+ case PGF_EXPR_APP: {
+ PgfExprApp* app = ei.data;
+ return pgf_compute_tree_probability(gr, app->fun) +
+ pgf_compute_tree_probability(gr, app->arg);
+ }
+ case PGF_EXPR_FUN: {
+ PgfExprFun* fun = ei.data;
+ PgfAbsFun* absfun =
+ gu_seq_binsearch(gr->abstract.funs, pgf_absfun_order, PgfAbsFun, fun->fun);
+ if (absfun == NULL)
+ return INFINITY;
+ else
+ return absfun->ep.prob;
+ }
+ default:
+ return 0;
+ }
+}
diff --git a/src/runtime/c/pgf/expr.h b/src/runtime/c/pgf/expr.h
index a30e44318..e28db7f31 100644
--- a/src/runtime/c/pgf/expr.h
+++ b/src/runtime/c/pgf/expr.h
@@ -226,4 +226,11 @@ PGF_API_DECL void
pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt,
GuOut* out, GuExn* err);
+PGF_API_DECL void
+pgf_print_category(PgfPGF *gr, PgfCId catname,
+ GuOut* out, GuExn *err);
+
+PGF_API prob_t
+pgf_compute_tree_probability(PgfPGF *gr, PgfExpr expr);
+
#endif /* EXPR_H_ */
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index 4523279dd..037145ee6 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -27,7 +27,7 @@ module PGF2 (-- * PGF
-- * Abstract syntax
AbsName,abstractName,
-- ** Categories
- Cat,categories,
+ Cat,categories,showCategory,
-- ** Functions
Fun,functions, functionsByCat, functionType, hasLinearization,
-- ** Expressions
@@ -39,6 +39,8 @@ module PGF2 (-- * PGF
mkFloat,unFloat,
mkMeta,unMeta,
mkCId,
+ treeProbability,
+
-- ** Types
Type, Hypo, BindType(..), startCat,
readType, showType,
@@ -210,15 +212,15 @@ unloadConcr :: Concr -> IO ()
unloadConcr c = pgf_concrete_unload (concr c)
-- | The type of a function
-functionType :: PGF -> Fun -> Type
+functionType :: PGF -> Fun -> Maybe Type
functionType p fn =
unsafePerformIO $
withGuPool $ \tmpPl -> do
c_fn <- newUtf8CString fn tmpPl
c_type <- pgf_function_type (pgf p) c_fn
- if c_type == nullPtr
- then throwIO (PGFError ("Function '"++fn++"' is not defined"))
- else return (Type c_type (touchPGF p))
+ return (if c_type == nullPtr
+ then Nothing
+ else Just (Type c_type (touchPGF p)))
-- | Checks an expression against a specified type.
checkExpr :: PGF -> Expr -> Type -> Either String Expr
@@ -314,6 +316,13 @@ compute (PGF p _) (Expr c_expr touch1) =
gu_pool_free exprPl
throwIO (PGFError msg)
+treeProbability :: PGF -> Expr -> Float
+treeProbability (PGF p _) (Expr c_expr touch1) =
+ unsafePerformIO $ do
+ res <- pgf_compute_tree_probability p c_expr
+ touch1
+ return (realToFrac res)
+
-----------------------------------------------------------------------------
-- Graphviz
@@ -965,8 +974,25 @@ categories p =
name <- peekUtf8CString (castPtr key)
writeIORef ref $! (name : names)
-categoryContext :: PGF -> Cat -> Maybe [Hypo]
-categoryContext pgf cat = Nothing -- !!! not implemented yet TODO
+showCategory :: PGF -> Cat -> String
+showCategory p cat =
+ unsafePerformIO $
+ withGuPool $ \tmpPl ->
+ do (sb,out) <- newOut tmpPl
+ exn <- gu_new_exn tmpPl
+ c_cat <- newUtf8CString cat tmpPl
+ pgf_print_category (pgf p) c_cat out exn
+ touchPGF p
+ failed <- gu_exn_is_raised exn
+ if failed
+ then do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn
+ if is_exn
+ then do c_msg <- (#peek GuExn, data.data) exn
+ msg <- peekUtf8CString c_msg
+ throwIO (PGFError msg)
+ else throwIO (PGFError "The abstract tree cannot be linearized")
+ else do s <- gu_string_buf_freeze sb tmpPl
+ peekUtf8CString s
-----------------------------------------------------------------------------
-- Helper functions
@@ -1023,7 +1049,7 @@ nerc pgf (lang,concr) sentence lin_idx offset =
((lemma,cat),_) = maximumBy (compare `on` snd) (reverse ls)
ls = [((fun,cat),p)
|(fun,_,p)<-lookupMorpho concr name,
- let cat=functionCat fun,
+ Just cat <- [functionCat fun],
cat/="Nationality"]
name = trimRight (concat capwords)
_ -> Nothing
@@ -1035,7 +1061,7 @@ nerc pgf (lang,concr) sentence lin_idx offset =
Just (y,xs') -> (y:ys,xs'')
where (ys,xs'') = consume munch xs'
- functionCat f = case unType (functionType pgf f) of (_,cat,_) -> cat
+ functionCat f = fmap ((\(_,c,_) -> c) . unType) (functionType pgf f)
-- | Callback to parse arbitrary words as chunks (from
-- ../java/org/grammaticalframework/pgf/UnknownLiteralCallback.java)
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs
index 1a5e7f91b..f25e52edf 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hs
+++ b/src/runtime/haskell-bind/PGF2/FFI.hs
@@ -325,6 +325,9 @@ foreign import ccall "pgf/pgf.h pgf_expr_unlit"
foreign import ccall "pgf/expr.h pgf_expr_arity"
pgf_expr_arity :: PgfExpr -> IO CInt
+foreign import ccall "pgf/expr.h pgf_compute_tree_probability"
+ pgf_compute_tree_probability :: Ptr PgfPGF -> PgfExpr -> IO CFloat
+
foreign import ccall "pgf/expr.h pgf_check_expr"
pgf_check_expr :: Ptr PgfPGF -> Ptr PgfExpr -> PgfType -> Ptr GuExn -> Ptr GuPool -> IO ()
@@ -343,6 +346,9 @@ foreign import ccall "pgf/expr.h pgf_print_expr"
foreign import ccall "pgf/expr.h pgf_print_expr_tuple"
pgf_print_expr_tuple :: CInt -> Ptr PgfExpr -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO ()
+foreign import ccall "pgf/expr.h pgf_print_category"
+ pgf_print_category :: Ptr PgfPGF -> CString -> Ptr GuOut -> Ptr GuExn -> IO ()
+
foreign import ccall "pgf/expr.h pgf_print_type"
pgf_print_type :: PgfType -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO ()
diff --git a/src/runtime/haskell-bind/PGF2/Type.hsc b/src/runtime/haskell-bind/PGF2/Type.hsc
index 7b4560abe..ada2b5e03 100644
--- a/src/runtime/haskell-bind/PGF2/Type.hsc
+++ b/src/runtime/haskell-bind/PGF2/Type.hsc
@@ -50,7 +50,7 @@ showType scope (Type ty touch) =
do (sb,out) <- newOut tmpPl
printCtxt <- newPrintCtxt scope tmpPl
exn <- gu_new_exn tmpPl
- pgf_print_type ty printCtxt 1 out exn
+ pgf_print_type ty printCtxt 0 out exn
touch
s <- gu_string_buf_freeze sb tmpPl
peekUtf8CString s
generated by cgit v1.2.3 (git 2.39.1) at 2026-08-04 22:18:54 +0000