diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master' of ssh://yap.git.sourceforge.net/gitroot/yap/yap-6.3

Browse Source
This commit is contained in:
Ricardo Rocha 2011-11-11 18:06:46 +00:00
commit 5c5fa5af55
136 changed files with 23300 additions and 460 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
H/Regs.h
View File

@ -15,6 +15,7 @@
/********* abstract machine registers **********************************/
#ifdef YAP_H
#ifdef CUT_C
#include "cut_c.h"
#endif
@ -22,6 +23,7 @@
#if defined MYDDAS_ODBC || defined MYDDAS_MYSQL
#include "myddas.h"
#endif
#endif
#define MaxTemps 512
#define MaxArithms 32

8
H/TermExt.h
View File

@ -64,7 +64,7 @@ inline EXTERN int IsAttVar (CELL *pt);
inline EXTERN int
IsAttVar (CELL *pt)
{
#ifdef _YAP_NOT_INSTALLED_
#ifdef YAP_H
CACHE_REGS
return (pt)[-1] == (CELL)attvar_e
&& pt < H;
@ -148,7 +148,7 @@ exts;
#endif
#ifdef _YAP_NOT_INSTALLED_
#ifdef YAP_H
/* make sure that these data structures are the first thing to be allocated
in the heap when we start the system */
@ -294,7 +294,7 @@ IsFloatTerm (Term t)
/* extern Functor FunctorLongInt; */
#ifdef _YAP_NOT_INSTALLED_
#ifdef YAP_H
inline EXTERN Term MkLongIntTerm (Int);
inline EXTERN Term
@ -604,7 +604,7 @@ IsAttachedTerm (Term t)
#endif
#ifdef _YAP_NOT_INSTALLED_
#ifdef YAP_H
inline EXTERN int STD_PROTO (unify_extension, (Functor, CELL, CELL *, CELL));

6
H/YapTags.h
View File

@ -184,7 +184,7 @@ IsUnboundVar (Term * t)
#else
#ifdef _YAP_NOT_INSTALLED_
#ifdef YAP_H
inline EXTERN Term MkVarTerm__ ( USES_REGS1 );
@ -316,7 +316,7 @@ IsIntTerm (Term t)
}
#ifdef _YAP_NOT_INSTALLED_
#ifdef YAP_H
EXTERN inline Term STD_PROTO (MkPairTerm__, (Term, Term CACHE_TYPE) );
EXTERN inline Term
@ -367,7 +367,7 @@ MkPairTerm__ (Term head, Term tail USES_REGS)
#define IsAccessFunc(func) ((func) == FunctorAccess)
#ifdef _YAP_NOT_INSTALLED_
#ifdef YAP_H
inline EXTERN Term MkIntegerTerm (Int);
inline EXTERN Term

3
H/YapTerm.h
View File

@ -13,12 +13,11 @@
* version: $Id: Yap.h,v 1.38 2008-06-18 10:02:27 vsc Exp $ *
*************************************************************************/
#ifndef _YAP_NOT_INSTALLED_
#ifndef YAP_H
#include "YapTermConfig.h"
typedef void *Functor;
typedef void *Atom;
#endif
#ifndef EXTERN

913
configure vendored
View File

File diff suppressed because it is too large Load Diff

19
configure.in
View File

@ -796,6 +796,13 @@ else
fi
AC_SUBST(ENABLE_GECODE)
if test "$use_prism" = no; then
ENABLE_PRISM="@# "
else
ENABLE_PRISM=""
fi
AC_SUBST(ENABLE_PRISM)
if test "$use_chr" = no; then
ENABLE_CHR="@# "
elif test -e "$srcdir"/packages/chr/Makefile.in; then
@ -2163,6 +2170,13 @@ mkdir -p packages/PLStream
mkdir -p packages/PLStream/libtai
mkdir -p packages/pldoc
mkdir -p packages/plunit
mkdir -p packages/prism
mkdir -p packages/prism/src
mkdir -p packages/prism/src/c
mkdir -p packages/prism/src/c/core
mkdir -p packages/prism/src/c/mp
mkdir -p packages/prism/src/c/up
mkdir -p packages/prism/src/prolog
mkdir -p packages/ProbLog
mkdir -p packages/ProbLog/simplecudd
mkdir -p packages/ProbLog/simplecudd_lfi
@ -2270,5 +2284,10 @@ if test "$ENABLE_GECODE" = ""; then
AC_CONFIG_FILES([library/gecode/Makefile])
fi
if test "$ENABLE_PRISM" = ""; then
AC_CONFIG_FILES([packages/prism/src/c/Makefile])
AC_CONFIG_FILES([packages/prism/src/prolog/Makefile])
fi
AC_OUTPUT()

4
include/YapRegs.h
View File

@ -23,6 +23,10 @@ typedef char *ADDR;
#define RESET_VARIABLE(X) (*(X) = (CELL)(X))
#ifdef _YAP_NOT_INSTALLED_
#include "Regs.h"
#else
#include "src/Regs.h"
#endif
#endif

8
library/dialect/bprolog/actionrules.pl
View File

@ -396,7 +396,8 @@ ar_expand(Head, []) :-
ar_expand(end_of_file, FinalProgram) :-
prolog_load_context(file,File),
compile_ar(File, DetProgram),
compile_nondet_ar(File, FinalProgram, DetProgram).
compile_nondet_ar(File, FinalProgram, DetProgram),
FinalProgram = [_|_].
compile_ar(File, FinalProgram) :-
findall(T, retract(ar_term(File,T)), ARs),
@ -404,11 +405,14 @@ compile_ar(File, FinalProgram) :-
prolog_load_context(module, Module),
ar_translate(ARs, Module, FinalProgram, Errors),
!, % just to make sure there are no choice points left
% vsc: also, allow for nondet rules.
(Errors == [] ->
true
;
report_errors(Errors)
).
compile_ar(_File, []).
compile_nondet_ar(File, FinalProgram, StartProgram) :-
findall(T, retract(nondet_ar_term(File,T)), ARs),
ARs \== [],
@ -420,6 +424,8 @@ compile_nondet_ar(File, FinalProgram, StartProgram) :-
;
report_errors(Errors)
).
compile_nondet_ar(_File, FinalProgram, FinalProgram).
report_errors(Errors) :- throw(action_rule_error(Errors)). % for now

93
packages/prism/LICENSE Normal file
View File

@ -0,0 +1,93 @@
LICENSE AGREEMENT OF THE PRISM SYSTEM
Copyright (c) 2009,
Taisuke Sato, Neng-Fa Zhou, Yoshitaka Kameya, Yusuke Izumi
All rights reserved.
The PRISM system ("the Software") is built on top of B-Prolog
(http://www.probp.com/), which is provided by Afany Software.
The Software is developed subject to the C source code license
of B-Prolog (http://www.probp.com/license.htm) and distributed
with the permission from Afany Software.
The PRISM development team, which consists of the members from
Tokyo Institute of Technology and from Afany Software, hereby
grants a non-exclusive and non-transferable license to the
person who uses the Software ("the User"), subject to this
agreement.
1. RELATION WITH B-PROLOG. The Software consists of the
standard routines of B-Prolog ("the B-Prolog part") and the
extensional routines by the PRISM development team ("the PRISM
part"). The User must agree that the use of the B-Prolog part
is also restricted by the license agreement of B-Prolog with
the exception stated in Paragraphs 3 and 4.
2. RIGHT TO USE. The User may use the Software provided
that the User has right to use B-Prolog according to the User's
license agreement of B-Prolog. Given the license agreement of
B-Prolog as of the release date of the Software, the User may
use the Software free of charge for academic and non-commercial
purposes, and must purchase a license for other use.
3. DISTRIBUTION. The User may distribute the Software, only
for non-commercial purposes, provided that the Software is
distributed along with this agreement.
4. SOURCE CODE AND DERIVED SOFTWARE. The PRISM development
team may make the source code of the PRISM part ("the Public
Source Code") publicly available under a separate license ("the
Additional License"), along with a minimal set of source and
binary files coming from the B-Prolog part and required to build
the Software ("the Build Kit"). The User may use and distribute
the Public Source Code and the Build Kit subject to the
following subparagraphs.
4.1. SOURCE CODE. The User may use and distribute the
Public Source Code, entirely or in part, subject to the
Additional License.
4.2. BUILD KIT. The User may use and distribute the Build
Kit according to the remaining subparagraphs, provided that
the User has right to use B-Prolog the User's license agreement
of B-Prolog. The Additional License shall not apply to the
Build Kit.
4.3. DERIVED SOFTWARE. The User may build software ("the
Derived Software") from the Public Source Code, modified or
unmodified, along with the Build Kit provided that (a) the User
has right to use the Build Kit as stated in Subparagraph 4.2,
and that (b) the Derived Software presents the following
message in the same way as the Software.
This edition of B-Prolog is for evaluation, learning, and
non-profit research purposes only, and a license is needed for
any other uses. Please visit http://www.probp.com/license.htm
for the detail.
4.4. DISTRIBUTION OF DERIVED SOFTWARE. The User may distribute
the Derived Software built according to Subparagraph 4.3, only
for non-commercial purposes, provided that the Derived Software
is distributed (a) along with this agreement and (b) under the
license consistent with this agreement.
5. COPYRIGHT. The B-Prolog part is copyrighted by Afany
Software and the PRISM part is copyrighted by the PRISM
development team. The Software contains several public domain
modules as listed in the B-Prolog's manual and the implementation
of Mersenne Twister copyrighted by its authors
(http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html), and
some portion of code in the PRISM part is based on the SPECFUN
library available in the NETLIB repository (http://www.netlib.org/).
The User shall own the copyright for the modified part of the
Software according to Subparagraph 3.3.
6. NO WARRANTY. The Software is provided "as-is", without
any warranties express or implied. The User may report any
defects of the Software to the PRISM development team, but
there is no guarantee for those defects to be fixed. The User
who purchased a license from Afany Software might receive a
warranty according to the license agreement of B-Prolog, only
when the defects obviously originate from the B-Prolog part.
Neither Afany Software nor the PRISM development team is
responsible for any damages caused by the use of the Software.

39
packages/prism/LICENSE.src Normal file
View File

@ -0,0 +1,39 @@
The following license agreement is referred to as the "Additional
License" in Paragraph 4 of a license agreement on the use of the
software, which is titled "LICENSE AGREEMENT OF THE PRISM SYSTEM."
--------------------------------------------------------------------
SOURCE CODE LICENSE AGREEMENT OF THE PRISM SYSTEM
Copyright (c) 2009,
Taisuke Sato, Neng-Fa Zhou, Yoshitaka Kameya, Yusuke Izumi
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* None of the name of Tokyo Institute of Technology, the name of
City University of New York, nor the names of its contributors
may be used to endorse or promote products derived from this
software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.

24
packages/prism/README Normal file
View File

@ -0,0 +1,24 @@
========================== README (top) ==========================
This is a software package of PRISM version 2.0, a logic-based
programming system for statistical modeling, which is built
on top of B-Prolog (http://www.probp.com/). Since version 2.0,
the source code of the PRISM part is included in the released
package. Please use PRISM based on the agreement described in
LICENSE and LICENSE.src.
LICENSE ... license agreement of PRISM
LICENSE.src ... additional license agreement on the source
code of PRISM
bin/ ... executables
doc/ ... documents
src/ ... source code
exs/ ... example programs
exs_fail/ ... example programs for generative modeling
with failure
exs_foc/ ... additional examples that demonstrate the
First Order Compiler
For the files under each directory, please read the README file
in the directory. For the papers or additional information
on PRISM, please visit http://sato-www.cs.titech.ac.jp/prism/ .

65
packages/prism/exs/README Normal file
View File

@ -0,0 +1,65 @@
========================== README (exs) ==========================
Files/Directories:
README ... this file
direction.psm ... the first example in the user's manual
dcoin.psm ... simple program modeling two Bernoulli trial processes
bloodABO.psm ... ABO blood type program (ABO gene model)
bloodAaBb.psm ... ABO blood type program (AaBb gene model)
bloodtype.dat ... data file for bloodABO.psm and bloodAaBb.psm
alarm.psm ... Bayesian network program
sbn.psm ... Singly connected Bayesian network program
hmm.psm ... discrete hidden Markov model
phmm.psm ... profile hmm for the alignment of amino-acid sequences
phmm.dat ... data file for phmm.psm
pdcg.psm ... PCFG program for top-down parsing
pdcg_c.psm ... PCFG program for Charniak's example
plc.psm ... probabilistic left-corner parsing
votes.psm ... cross-validation of naive Bayes with the `votes' data
jtree/ ... Bayesian network program in a junction-tree form
noisy_or/ ... Bayesian network program using noisy OR
How to use:
All programs are self-contained, hopefully. Try first a sample
session in each program to get familiar with a model.
Comment:
The above programs contain no negation. When a program contains
negation, you have to compile away negation by FOC (first order
compiler). For PRISM programs with negation, see ../exs_fail.
References:
(PRISM)
Parameter Learning of Logic Programs for Symbolic-statistical Modeling,
Sato,T. and Kameya,Y.,
Journal of Artificial Intelligence Research 15, pp.391-454, 2001.
New advances in logic-based probabilistic modeling by PRISM,
Sato,T. and Kameya,Y.,
Probabilistic Inductive Logic Programming, LNCS 4911, Springer,
pp.118-155, 2008.
(PCFGs)
Foundations of Statistical Natural Language Processing,
Manning,C.D. and Schutze,H.,
The MIT Press, 1999.
A Separate-and-Learn Approach to EM Learning of PCFGs
Sato,T., Abe,S., Kameya,Y. and Shirai,K.,
Proc. of the 6th Natural Language Processing Pacific Rim Symposium
(NLRPS-2001), pp.255-262, 2001.
(BNs)
Probabilistic Reasoning in Intelligent Systems,
Pearl,J.,
Morgan Kaufmann, 1988.
Expert Systems and Probabilistic Network Models,
Castillo,E., Gutierrez,J.M. and Hadi,A.S.,
Springer-Verlag, 1997.
(HMMs)
Foundations of Speech Recognition,
Rabiner,L.R. and Juang,B.,
Prentice-Hall, 1993.

122
packages/prism/exs/alarm.psm Normal file
View File

@ -0,0 +1,122 @@
%%%%
%%%% Bayesian networks (1) -- alarm.psm
%%%%
%%%% Copyright (C) 2004,2006,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This example is borrowed from:
%% Poole, D., Probabilistic Horn abduction and Bayesian networks,
%% In Proc. of Artificial Intelligence 64, pp.81-129, 1993.
%%
%% (Fire) (Tampering)
%% / \ /
%% ((Smoke)) (Alarm)
%% |
%% (Leaving) (( )) -- observable node
%% | ( ) -- hidden node
%% ((Report))
%%
%% In this network, we assume that all rvs (random variables)
%% take on {yes,no} and also assume that only two nodes, `Smoke'
%% and `Report', are observable.
%%-------------------------------------
%% Quick start : sample session
%%
%% ?- prism(alarm),go. % Learn parameters from randomly generated
%% % 100 samples
%%
%% Get the probability and the explanation graph:
%% ?- prob(world(yes,no)).
%% ?- probf(world(yes,no)).
%%
%% Get the most likely explanation and its probability:
%% ?- viterbif(world(yes,no)).
%% ?- viterbi(world(yes,no)).
%%
%% Compute conditional hindsight probabilities:
%% ?- chindsight(world(yes,no)).
%% ?- chindsight_agg(world(yes,no),world(_,_,query,yes,_,no)).
go:- alarm_learn(100).
%%-------------------------------------
%% Declarations:
:- set_prism_flag(data_source,file('world.dat')).
% When we run learn/0, the data are supplied
% from `world.dat'.
values(_,[yes,no]). % We declare multiary random switch msw(.,V)
% used in this program such that V (outcome)
% is one of {yes,no}. Note that '_' is
% an anonymous logical variable in Prolog.
% The distribution of V is specified by
% set_params below.
%%------------------------------------
%% Modeling part:
%%
%% The above BN defines a joint distribution
%% P(Fire,Tapering,Smoke,Alarm,Leaving,Report).
%% We assume `Smoke' and `Report' are observable while others are not.
%% Our modeling simulates random sampling of the BN from top nodes
%% using msws. For each rv, say `Fire', we introduce a corresponding
%% msw, say msw(fi,Fi) such that
%% msw(fi,Fi) <=> sampling msw named fi yields the outcome Fi.
%% Here fi is a constant intended for the name of rv `Fire.'
%%
world(Fi,Ta,Al,Sm,Le,Re) :-
%% Define a distribution for world/5 such that e.g.
%% P(Fire=yes,Tapering=yes,Smoke=no,Alarm=no,Leaving=no,Report=no)
%% = P(world(yes,yes,no,no,no,no))
msw(fi,Fi), % P(Fire)
msw(ta,Ta), % P(Tampering)
msw(sm(Fi),Sm), % CPT P(Smoke | Fire)
msw(al(Fi,Ta),Al), % CPT P(Alarm | Fire,Tampering)
msw(le(Al),Le), % CPT P(Leaving | Alarm)
msw(re(Le),Re). % CPT P(Report | Leaving)
world(Sm,Re):-
%% Define marginal distribution for `Smoke' and `Report'
world(_,_,_,Sm,_,Re).
%%------------------------------------
%% Utility part:
alarm_learn(N) :-
unfix_sw(_), % Make all parameters changeable
set_params, % Set parameters as you specified
get_samples(N,world(_,_),Gs), % Get N samples
fix_sw(fi), % Preserve the parameter values
learn(Gs). % for {msw(fi,yes), msw(fi,no)}
% alarm_learn(N) :-
% %% generate teacher data and write them to `world.dat'
% %% before learn/0 is called.
% write_world(N,'world.dat'),
% learn.
set_params :-
set_sw(fi,[0.1,0.9]),
set_sw(ta,[0.15,0.85]),
set_sw(sm(yes),[0.95,0.05]),
set_sw(sm(no),[0.05,0.95]),
set_sw(al(yes,yes),[0.50,0.50]),
set_sw(al(yes,no),[0.90,0.10]),
set_sw(al(no,yes),[0.85,0.15]),
set_sw(al(no,no),[0.05,0.95]),
set_sw(le(yes),[0.88,0.12]),
set_sw(le(no),[0.01,0.99]),
set_sw(re(yes),[0.75,0.25]),
set_sw(re(no),[0.10,0.90]).
write_world(N,File) :-
get_samples(N,world(_,_),Gs),tell(File),write_world(Gs),told.
write_world([world(Sm,Re)|Gs]) :-
write(world(Sm,Re)),write('.'),nl,write_world(Gs).
write_world([]).

111
packages/prism/exs/bloodABO.psm Normal file
View File

@ -0,0 +1,111 @@
%%%%
%%%% ABO blood type --- bloodABO.psm
%%%%
%%%% Copyright (C) 2004,2006,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% ABO blood type consists of A, B, O and AB. They are observable
%% (phenotypes) and determined by a pair of blood type genes (geneotypes).
%% There are three ABO genes, namely a, b and o located on the 9th
%% chromosome of a human being. There are 6 geneotypes ({a,a},{a,b},{a,o},
%% {b,b},{b,o},{o,o}) and each determines a blood type. For example {a,b}
%% gives blood type AB etc. Our task is to estimate frequencies of ABO
%% genes from a random sample of ABO blood type, assuming random mate.
%%-------------------------------------
%% Quick start : sample session
%%
%% ?- prism(bloodABO),go,print_blood.
%% % Learn parameters from randomly generated
%% % 100 samples with A:B:O:AB = 38:22:31:9
%%
%% ?- sample(bloodtype(X)).
%% % Pick up a person with blood type X randomly
%% % acccording to the currrent parameter settings
%%
%% ?- get_samples(100,bloodtype(X),_Gs),countlist(_Gs,Cs).
%% % Pick up 100 persons and get the frequencies
%% % of their blood types
%%
%% ?- probf(bloodtype(ab),E),print_graph(E).
%% % Print all explanations for blooodtype(ab) in
%% % a compressed form
%%
%% ?- prob(bloodtype(ab),P).
%% % P is the probability of bloodtype(ab) being true
%%
%% ?- viterbif(bloodtype(ab)).
%% ?- viterbif(bloodtype(ab),P,E),print_graph(E).
%% ?- viterbi(bloodtype(ab),P).
%% % P is the probability of a most likely
%% % explanation E for bloodtype(ab).
%%
%% ?- viterbit(bloodtype(ab)).
%% % Print the most likely explanation for
%% % bloodtype(ab) in a tree form.
go:- learn_bloodtype(100).
%%-------------------------------------
%% Declarations:
:- set_prism_flag(data_source,file('bloodtype.dat')).
% When we run learn/0, the data are supplied
% by `bloodtype.dat'.
values(gene,[a,b,o],[0.5,0.2,0.3]).
% We declare msw(gene,V) s.t. V takes on
% one of the genes {a,b,o} when executed,
% with the freq.: a 50%, b 20%, o 30%.
%%------------------------------------
%% Modeling part:
bloodtype(P) :-
genotype(X,Y),
( X=Y -> P=X
; X=o -> P=Y
; Y=o -> P=X
; P=ab
).
genotype(X,Y) :- msw(gene,X),msw(gene,Y).
% We assume random mate. Note that msw(gene,X)
% and msw(gene,Y) are i.i.d. (independent and
% identically distributed) random variables
% in Prism because they have the same id but
% different subgoals.
%%------------------------------------
%% Utility part:
learn_bloodtype(N) :- % Learn parameters from N observations
random_set_seed(214857), % Set seed of the random number generator
gen_bloodtype(N,Gs),!, % Sample bloodtype/1 of size N
learn(Gs). % Perform search and graphical EM learning
% learn. % <= when using the file `bloodtype.dat'
gen_bloodtype(N,Gs) :-
N > 0,
random_select([a,b,o,ab],[0.38,0.22,0.31,0.09],X),
Gs = [bloodtype(X)|Gs1], % Sample a blood type with an empirical
N1 is N-1,!, % ratio for Japanese people.
gen_bloodtype(N1,Gs1).
gen_bloodtype(0,[]).
print_blood :-
prob(bloodtype(a),PA),prob(bloodtype(b),PB),
prob(bloodtype(o),PO),prob(bloodtype(ab),PAB),
nl,
format("P(A) = ~6f~n",[PA]),
format("P(B) = ~6f~n",[PB]),
format("P(O) = ~6f~n",[PO]),
format("P(AB) = ~6f~n",[PAB]).
print_gene :-
get_sw(gene,[_,[a,b,o],[GA,GB,GO]]),
nl,
format("P(a) = ~6f~n",[GA]),
format("P(b) = ~6f~n",[GB]),
format("P(o) = ~6f~n",[GO]).

114
packages/prism/exs/bloodAaBb.psm Normal file
View File

@ -0,0 +1,114 @@
%%%%
%%%% Another hypothesis on ABO blood type inheritance --- bloodAaBb.psm
%%%%
%%%% Copyright (C) 2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% ABO blood type consists of A, B, O and AB. They are observable
%% (phenotypes) and determined by a pair of blood type genes (geneotypes).
%% At present, it is known that there are three ABO genes, namely a, b and
%% o located on the 9th chromosome of a human being, but in early 20th
%% century, there was another hypothesis that we have two loci for ABO
%% blood type with dominant alleles A/a and B/b. That is, genotypes aabb,
%% A*bb, aaB* and A*B* correspond to the blood types (phenotypes) O, A, B
%% and AB, respectively, where * stands for a don't care symbol. We call
%% this hypothesis the AaBb gene model, and assume random mating.
%%-------------------------------------
%% Quick start : sample session -- the same as that of bloodABO.psm
%%
%% ?- prism(bloodAaBb),go,print_blood.
%% % Learn parameters from randomly generated
%% % 100 samples with A:B:O:AB = 38:22:31:9
%%
%% ?- probf(bloodtype(ab),E),print_graph(E).
%% ?- prob(bloodtype(ab),P).
%%
%% ?- viterbif(bloodtype(ab),P,E),print_graph(E).
%% ?- viterbi(bloodtype(ab),P).
%% % P is the probability of a most likely
%% % explanation E for bloodtype(ab).
go:- learn_bloodtype(100).
%%-------------------------------------
%% Session for model selection:
%%
%% -- we try to evaluate the plausibilities of the correct model (ABO
%% gene model) and this AaBb gene model according to the data in
%% `bloodtype.dat'. The data file `bloodtype.dat' contains 38
%% persons of blood type A, 22 persons of blood type B, 31 persons
%% of blood type O, and 9 persons of blood type AB (the ratio is
%% almost the same as that in Japanese people).
%%
%% 1. Modify bloodABO.psm and bloodAaBb.psm:
%% - Use learn/0 instead of learn/1.
%%
%% 2. Get the BIC value for the ABO gene model (bloodABO.psm)
%% ?- prism(bloodABO).
%% ?- learn.
%% ?- learn_statistics(bic,BIC).
%%
%% 3. Get the BIC value for the AaBb gene model (this file)
%% ?- prism(bloodAaBb).
%% ?- learn.
%% ?- learn_statistics(bic,BIC).
%%
:- set_prism_flag(data_source,file('bloodtype.dat')).
% When we run learn/0, the data are supplied
% by `bloodtype.dat'.
values(locus1,['A',a]).
values(locus2,['B',b]).
%%------------------------------------
%% Modeling part:
bloodtype(P) :-
genotype(locus1,X1,Y1),
genotype(locus2,X2,Y2),
( X1=a, Y1=a, X2=b, Y2=b -> P=o
; ( X1='A' ; Y1='A' ), X2=b, Y2=b -> P=a
; X1=a, Y1=a, ( X2='B' ; Y2='B') -> P=b
; P=ab
).
genotype(L,X,Y) :- msw(L,X),msw(L,Y).
%%------------------------------------
%% Utility part:
%% (the same as that in bloodABO.psm)
learn_bloodtype(N) :- % Learn parameters from N observations
random_set_seed(214857), % Set seed of the random number generator
gen_bloodtype(N,Gs),!, % Sample bloodtype/1 of size N
learn(Gs). % Perform search and graphical EM learning
% learn. % <= when using the file `bloodtype.dat'
gen_bloodtype(N,Gs) :-
N > 0,
random_select([a,b,o,ab],[0.38,0.22,0.31,0.09],X),
Gs = [bloodtype(X)|Gs1], % Sample a blood type with an empirical
N1 is N-1,!, % ratio for Japanese people.
gen_bloodtype(N1,Gs1).
gen_bloodtype(0,[]).
print_blood :-
prob(bloodtype(a),PA),prob(bloodtype(b),PB),
prob(bloodtype(o),PO),prob(bloodtype(ab),PAB),
nl,
format("P(A) = ~6f~n",[PA]),
format("P(B) = ~6f~n",[PB]),
format("P(O) = ~6f~n",[PO]),
format("P(AB) = ~6f~n",[PAB]).
print_gene :-
get_sw(locus1,[_,['A',a],[GA,Ga]]),
get_sw(locus2,[_,['B',b],[GB,Gb]]),
nl,
format("P(A) = ~6f~n",[GA]),
format("P(a) = ~6f~n",[Ga]),
format("P(B) = ~6f~n",[GB]),
format("P(b) = ~6f~n",[Gb]).

100
packages/prism/exs/bloodtype.dat Normal file
View File

@ -0,0 +1,100 @@
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(ab).
bloodtype(ab).
bloodtype(ab).
bloodtype(ab).
bloodtype(ab).
bloodtype(ab).
bloodtype(ab).
bloodtype(ab).
bloodtype(ab).

72
packages/prism/exs/dcoin.psm Normal file
View File

@ -0,0 +1,72 @@
%%%%
%%%% Double coin tossing --- dcoin.psm
%%%%
%%%% Copyright (C) 2004,2006,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% A sequential mixture of two Bernoulli trials processes.
%% We have two coins, coin(1) and coin(2).
%% Start with coin(1), we keep flipping a coin and observe the outcome.
%% We change coins according to the rule in the process.
%% If the outcome is "head", the next coin to flip is coin(2).
%% If the outcome is "tail", the next coin to flip is coin(1).
%% The learning task is to estimate parameters for coin(1) and coin(2),
%% observing a sequence of outcomes.
%% As there is no hidden variable in this model, EM learning is just
%% ML estimation from complete data.
%%-------------------------------------
%% Quick start : sample session
%%
%% (1) load this program
%% ?- prism(dcoin).
%%
%% (2) sampling and probability computations
%% ?- sample(dcoin(10,X)),prob(dcoin(10,X)).
%% ?- sample(dcoin(10,X)),probf(dcoin(10,X)).
%%
%% (3) EM learning
%% ?- go.
go:- dcoin_learn(500).
%%------------------------------------
%% Declarations:
values(coin(1),[head,tail],[0.5,0.5]).
% Declare msw(coin(1),V) s.t. V = head or
% V = tail, where P(msw(coin(1),head)) = 0.5
% and P(msw(coin(1),tail)) = 0.5.
values(coin(2),[head,tail],[0.7,0.3]).
% Declare msw(coin(2),V) s.t. V = head or
% V = tail, where P(msw(coin(2),head)) = 0.7
% and P(msw(coin(2),tail)) = 0.3.
%%------------------------------------
%% Modeling part:
dcoin(N,Rs) :- % Rs is a list with length N of outcomes
dcoin(N,coin(1),Rs). % from two Bernoulli trials processes.
dcoin(N,Coin,[R|Rs]) :-
N > 0,
msw(Coin,R),
( R == head, NextCoin = coin(2)
; R == tail, NextCoin = coin(1) ),
N1 is N-1,
dcoin(N1,NextCoin,Rs).
dcoin(0,_,[]).
%%------------------------------------
%% Utility part:
dcoin_learn(N) :-
set_params, % Set parameters.
sample(dcoin(N,Rs)), % Get a sample Rs of size N.
Goals = [dcoin(N,Rs)], % Estimate the parameters from Rs.
learn(Goals).
set_params :-
set_sw(coin(1),[0.5,0.5]),
set_sw(coin(2),[0.7,0.3]).

46
packages/prism/exs/direction.psm Normal file
View File

@ -0,0 +1,46 @@
%%%%
%%%% Decision of the direction by a coin tossing -- direction.psm
%%%%
%%%% This program has just one random switch named `coin'.
%%%%
%%%% Copyright (C) 2004,2006,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%%-------------------------------------
%% Sample session
%%
%% (1) Load this program:
%% ?- prism(direction).
%%
%% (2) Get a sample:
%% ?- sample(direction(D)).
%%
%% (3) Display the information about the switch `coin':
%% ?- show_sw.
%%
%% (4) Set the probability distribution to the switch `coin':
%% ?- set_sw(coin,[0.7,0.3]).
%%
%% (5) Display the switch information again with the distribution set
%% at step 4:
%% ?- show_sw.
%%
%% (6) Get a sample again with the distribution set at step 4:
%% ?- sample(direction(D)).
%%
%% [Note1]
%% Since 1.9, without any extra settings, the probability distribution
%% of every switch is set to a uniform distribution.
%%
%% [Note2]
%% If you go (3) with skipping (2), nothing should be displayed. This
%% is because any random switch will not be registered by the system until
%% it is explicitly used or referred to.
values(coin,[head,tail]). % The switch `coin' takes `head' or `tail' as its value
direction(D):-
msw(coin,Face), % Make a coin tossing
( Face==head -> D=left ; D=right). % Decide the direction according to
% the result of coin tossing

99
packages/prism/exs/hmm.psm Normal file
View File

@ -0,0 +1,99 @@
%%%%
%%%% Hidden Markov model --- hmm.psm
%%%%
%%%% Copyright (C) 2004,2006,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% [state diagram:] (2 states and 2 output symbols)
%%
%% +--------+ +--------+
%% | | | |
%% | +------+ +------+ |
%% | | |------->| | |
%% +---->| s0 | | s1 |<----+
%% | |<-------| |
%% +------+ +------+
%%
%% - In each state, possible output symbols are `a' and `b'.
%%-------------------------------------
%% Quick start : sample session
%%
%% ?- prism(hmm),hmm_learn(100). % Learn parameters from 100 randomly
%% % generated samples
%%
%% ?- show_sw. % Confirm the learned parameter
%%
%% ?- prob(hmm([a,a,a,a,a,b,b,b,b,b])). % Calculate the probability
%% ?- probf(hmm([a,a,a,a,a,b,b,b,b,b])). % Get the explanation graph
%%
%% ?- viterbi(hmm([a,a,a,a,a,b,b,b,b,b])). % Run the Viterbi computation
%% ?- viterbif(hmm([a,a,a,a,a,b,b,b,b,b])). % Get the Viterbi explanation
%%
%% ?- hindsight(hmm([a,a,a,a,a,b,b,b,b,b])). % Get hindsight probabilities
%%------------------------------------
%% Declarations:
values(init,[s0,s1]). % state initialization
values(out(_),[a,b]). % symbol emission
values(tr(_),[s0,s1]). % state transition
% :- set_prism_flag(default_sw_d,1.0).
% :- set_prism_flag(epsilon,1.0e-2).
% :- set_prism_flag(restart,10).
% :- set_prism_flag(log_scale,on).
%%------------------------------------
%% Modeling part:
hmm(L):- % To observe a string L:
str_length(N), % Get the string length as N
msw(init,S), % Choose an initial state randomly
hmm(1,N,S,L). % Start stochastic transition (loop)
hmm(T,N,_,[]):- T>N,!. % Stop the loop
hmm(T,N,S,[Ob|Y]) :- % Loop: current state is S, current time is T
msw(out(S),Ob), % Output Ob at the state S
msw(tr(S),Next), % Transit from S to Next.
T1 is T+1, % Count up time
hmm(T1,N,Next,Y). % Go next (recursion)
str_length(10). % String length is 10
%%------------------------------------
%% Utility part:
hmm_learn(N):-
set_params,!, % Set parameters manually
get_samples(N,hmm(_),Gs),!, % Get N samples
learn(Gs). % Learn with the samples
set_params:-
set_sw(init, [0.9,0.1]),
set_sw(tr(s0), [0.2,0.8]),
set_sw(tr(s1), [0.8,0.2]),
set_sw(out(s0),[0.5,0.5]),
set_sw(out(s1),[0.6,0.4]).
%% prism_main/1 is a special predicate for batch execution.
%% The following command conducts learning from 50 randomly
%% generated samples:
%% > upprism hmm 50
prism_main([Arg]):-
parse_atom(Arg,N), % Convert an atom ('50') to a number (50)
hmm_learn(N). % Learn with N samples
%% viterbi_states(Os,Ss) returns the most probable sequence Ss
%% of state transitions for an output sequence Os.
%%
%% | ?- viterbi_states([a,a,a,a,a,b,b,b,b,b],States).
%%
%% States = [s0,s1,s0,s1,s0,s1,s0,s1,s0,s1,s0] ?
viterbi_states(Outputs,States):-
viterbif(hmm(Outputs),_,E),
viterbi_subgoals(E,E1),
maplist(hmm(_,_,S,_),S,true,E1,States).

8
packages/prism/exs/jtree/README Normal file
View File

@ -0,0 +1,8 @@
================== README (exs/jtree) ==========================
Files:
README ... This file
asia.psm ... BN for Asia network (naive)
jasia.psm ... BN for Asia network (junction-tree; evidences kept in D-list)
jasia_a.psm ... BN for Asia network (junction-tree; evidences asserted first)
bn2prism/ ... Java translator from BNs to join-tree PRISM programs

84
packages/prism/exs/jtree/asia.psm Normal file
View File

@ -0,0 +1,84 @@
%%%%
%%%% Bayesian networks for Asia network -- asia.psm
%%%%
%%%% Copyright (C) 2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This example is known as the Asia network, and was borrowed from:
%% S. L. Lauritzen and D. J. Spiegelhalter (1988).
%% Local computations with probabilities on graphical structures
%% and their application to expert systems.
%% Journal of Royal Statistical Society, Vol.B50, No.2, pp.157-194.
%%
%% ((Smoking[S]))
%% ((Visit to Asia[A])) / \
%% | / \
%% v v \
%% (Tuberculosis[T]) (Lang cancer[L]) \
%% \ / \
%% \ / v
%% v v (Bronchinitis[B])
%% (Tuberculosis or lang cancer[TL]) /
%% / \ /
%% / \ /
%% v \ /
%% ((X-ray[X])) v v
%% ((Dyspnea[D]))
%%
%% We assume that the nodes A, S, X and D are observable. This
%% program provides a naive representation of the Asia network, as
%% shown in ../alarm.psm. The junction-tree version of the Asia
%% network program is given in jasia.psm
%%-------------------------------------
%% Quick start:
%%
%% ?- prism(asia),go.
go:- chindsight_agg(world(f,_,_,t),world(f,query,_,_,_,_,_,t)).
% we compute a conditional distribution P(T | A=false, D=true)
%%-------------------------------------
%% Declarations:
values(bn(_,_),[t,f]). % each switch takes on true or false
%%-------------------------------------
%% Modeling part:
world(A,S,X,D):- world(A,_,S,_,_,X,_,D).
world(A,T,S,L,TL,X,B,D) :-
msw(bn(a,[]),A),msw(bn(t,[A]),T),
msw(bn(s,[]),S),msw(bn(l,[S]),L),
incl_or(T,L,TL),
msw(bn(x,[TL]),X),msw(bn(b,[S]),B),
msw(bn(d,[TL,B]),D).
% inclusive OR
incl_or(t,t,t).
incl_or(t,f,t).
incl_or(f,t,t).
incl_or(f,f,f).
%%-------------------------------------
%% Utility part:
:- set_params.
set_params:-
set_sw(bn(a,[]),[0.01,0.99]),
set_sw(bn(t,[t]),[0.05,0.95]),
set_sw(bn(t,[f]),[0.01,0.99]),
set_sw(bn(s,[]),[0.5,0.5]),
set_sw(bn(l,[t]),[0.1,0.9]),
set_sw(bn(l,[f]),[0.01,0.99]),
set_sw(bn(x,[t]),[0.98,0.02]),
set_sw(bn(x,[f]),[0.05,0.95]),
set_sw(bn(b,[t]),[0.60,0.40]),
set_sw(bn(b,[f]),[0.30,0.70]),
set_sw(bn(d,[t,t]),[0.90,0.10]),
set_sw(bn(d,[t,f]),[0.70,0.30]),
set_sw(bn(d,[f,t]),[0.80,0.20]),
set_sw(bn(d,[f,f]),[0.10,0.90]).

153
packages/prism/exs/jtree/jasia.psm Normal file
View File

@ -0,0 +1,153 @@
%%%%
%%%% Join-tree PRISM program for Asia network -- jasia.psm
%%%%
%%%% Copyright (C) 2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This example is known as the Asia network, and was borrowed from:
%% S. L. Lauritzen and D. J. Spiegelhalter (1988).
%% Local computations with probabilities on graphical structures
%% and their application to expert systems.
%% Journal of Royal Statistical Society, Vol.B50, No.2, pp.157-194.
%%
%% ((Smoking[S]))
%% ((Visit to Asia[A])) / \
%% | / \
%% v v \
%% (Tuberculosis[T]) (Lang cancer[L]) \
%% \ / \
%% \ / v
%% v v (Bronchinitis[B])
%% (Tuberculosis or lang cancer[TL]) /
%% / \ /
%% / \ /
%% v \ /
%% ((X-ray[X])) v v
%% ((Dyspnea[D]))
%%
%% We assume that the nodes A, S, X and D are observable. One may
%% notice that this network is multiply-connected (there are undirected
%% loop: S-L-TL-D-B-S). To perform efficient probabilistic inferences,
%% one popular method is the join-tree (JT) algorithm. In the JT
%% algorithm, we first convert the original network (DAG) into a tree-
%% structured undirected graph, called join tree (junction tree), in
%% which a node corresponds to a set of nodes in the original network.
%% Then we compute the conditional probabilities based on the join
%% tree. For example, the above network is converted into the
%% following join tree:
%%
%% node4(A,T) node2(S,L,B)
%% \ \
%% [T] [L,B]
%% \ \ node1
%% node3(T,L,TL)--[L,TL]--(L,TL,B)
%% /
%% [TL,B]
%% node6 /
%% (TL,X)--[TL]--(TL,B,D)
%% node5
%%
%% where (...) corresponds to a node and [...] corresponds to a
%% separator. In this join tree, node2 corresponds to a set {S,L,B} of
%% the original nodes. We consider that node1 is the root of this join
%% tree.
%%
%% Here we write a PRISM program that represents the above join tree.
%% The predicate named msg_i_j corresponds to the edge from node i to
%% node j in the join tree. The predicate named node_i corresponds to
%% node i.
%%
%% The directory `bn2prism' in the same directory contains BN2Prism, a
%% Java translator from a Bayesian network to a PRISM program in join-
%% tree style, like the one shown here.
%%-------------------------------------
%% Quick start:
%%
%% ?- prism(jasia),go.
go:- chindsight_agg(world([(a,f),(d,t)]),node_4(_,query,_)).
% we compute a conditional distribution P(T | A=false, D=true)
go2:- prob(world([(a,f),(d,t)])).
% we compute a marginal probability P(A=false, D=true)
%%-------------------------------------
%% Declarations:
values(bn(_,_),[t,f]). % each switch takes on true or false
%%-------------------------------------
%% Modeling part:
%%
%% [Note]
%% Evidences are kept in a difference list in the last argument of
%% the msg_i_j and the node_i predicates. For simplicity, it is
%% assumed that the evidences are given in the same order as that
%% of appearances of msw/2 in the top-down execution of world/1.
world(E):- msg_1_0(E-[]).
msg_1_0(E0-E1) :- node_1(_L,_TL,_B,E0-E1).
msg_2_1(L,B,E0-E1 ):- node_2(_S,L,B,E0-E1).
msg_3_1(L,TL,E0-E1):- node_3(_T,L,TL,E0-E1).
msg_4_3(T,E0-E1) :- node_4(_A,T,E0-E1).
msg_5_1(TL,B,E0-E1):- node_5(TL,B,_D,E0-E1).
msg_6_5(TL,E0-E1) :- node_6(TL,_X,E0-E1).
node_1(L,TL,B,E0-E1):-
msg_2_1(L,B,E0-E2),
msg_3_1(L,TL,E2-E3),
msg_5_1(TL,B,E3-E1).
node_2(S,L,B,E0-E1):-
cpt(s,[],S,E0-E2),
cpt(l,[S],L,E2-E3),
cpt(b,[S],B,E3-E1).
node_3(T,L,TL,E0-E1):-
incl_or(L,T,TL),
msg_4_3(T,E0-E1).
node_4(A,T,E0-E1):-
cpt(a,[],A,E0-E2),
cpt(t,[A],T,E2-E1).
node_5(TL,B,D,E0-E1):-
cpt(d,[TL,B],D,E0-E2),
msg_6_5(TL,E2-E1).
node_6(TL,X,E0-E1):-
cpt(x,[TL],X,E0-E1).
cpt(X,Par,V,E0-E1):-
( E0=[(X,V)|E1] -> true ; E0=E1 ),
msw(bn(X,Par),V).
% inclusive OR
incl_or(t,t,t).
incl_or(t,f,t).
incl_or(f,t,t).
incl_or(f,f,f).
%%-------------------------------------
%% Utility part:
:- set_params.
set_params:-
set_sw(bn(a,[]),[0.01,0.99]),
set_sw(bn(t,[t]),[0.05,0.95]),
set_sw(bn(t,[f]),[0.01,0.99]),
set_sw(bn(s,[]),[0.5,0.5]),
set_sw(bn(l,[t]),[0.1,0.9]),
set_sw(bn(l,[f]),[0.01,0.99]),
set_sw(bn(x,[t]),[0.98,0.02]),
set_sw(bn(x,[f]),[0.05,0.95]),
set_sw(bn(b,[t]),[0.60,0.40]),
set_sw(bn(b,[f]),[0.30,0.70]),
set_sw(bn(d,[t,t]),[0.90,0.10]),
set_sw(bn(d,[t,f]),[0.70,0.30]),
set_sw(bn(d,[f,t]),[0.80,0.20]),
set_sw(bn(d,[f,f]),[0.10,0.90]).

167
packages/prism/exs/jtree/jasia_a.psm Normal file
View File

@ -0,0 +1,167 @@
%%%%
%%%% Join-tree PRISM program for Asia network -- jasia.psm
%%%%
%%%% Copyright (C) 2009
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This example is known as the Asia network, and was borrowed from:
%% S. L. Lauritzen and D. J. Spiegelhalter (1988).
%% Local computations with probabilities on graphical structures
%% and their application to expert systems.
%% Journal of Royal Statistical Society, Vol.B50, No.2, pp.157-194.
%%
%% ((Smoking[S]))
%% ((Visit to Asia[A])) / \
%% | / \
%% v v \
%% (Tuberculosis[T]) (Lang cancer[L]) \
%% \ / \
%% \ / v
%% v v (Bronchinitis[B])
%% (Tuberculosis or lang cancer[TL]) /
%% / \ /
%% / \ /
%% v \ /
%% ((X-ray[X])) v v
%% ((Dyspnea[D]))
%%
%% We assume that the nodes A, S, X and D are observable. One may
%% notice that this network is multiply-connected (there are undirected
%% loop: S-L-TL-D-B-S). To perform efficient probabilistic inferences,
%% one popular method is the join-tree (JT) algorithm. In the JT
%% algorithm, we first convert the original network (DAG) into a tree-
%% structured undirected graph, called join tree (junction tree), in
%% which a node corresponds to a set of nodes in the original network.
%% Then we compute the conditional probabilities based on the join
%% tree. For example, the above network is converted into the
%% following join tree:
%%
%% node4(A,T) node2(S,L,B)
%% \ \
%% [T] [L,B]
%% \ \ node1
%% node3(T,L,TL)--[L,TL]--(L,TL,B)
%% /
%% [TL,B]
%% node6 /
%% (TL,X)--[TL]--(TL,B,D)
%% node5
%%
%% where (...) corresponds to a node and [...] corresponds to a
%% separator. In this join tree, node2 corresponds to a set {S,L,B} of
%% the original nodes. We consider that node1 is the root of this join
%% tree.
%%
%% Here we write a PRISM program that represents the above join tree.
%% The predicate named msg_i_j corresponds to the edge from node i to
%% node j in the join tree. The predicate named node_i corresponds to
%% node i.
%%
%% The directory `bn2prism' in the same directory contains BN2Prism, a
%% Java translator from a Bayesian network to a PRISM program in join-
%% tree style, like the one shown here.
%%-------------------------------------
%% Quick start:
%%
%% ?- prism(jasia_a),go.
go:- chindsight_agg(world([(a,f),(d,t)]),node_4(_,query)).
% we compute a conditional distribution P(T | A=false, D=true)
go2:- prob(world([(a,f),(d,t)])).
% we compute a marginal probability P(A=false, D=true)
%%-------------------------------------
%% Declarations:
values(bn(_,_),[t,f]). % each switch takes on true or false
%%-------------------------------------
%% Modeling part:
%%
%% [Note]
%% Evidences are added first into the Prolog database. This is a
%% simpler method than keeping the evidences in difference list
%% (as done in jasia.psm). However, in learning, the subgoals are
%% inappropriately shared among the observed goals, each of which
%% is associated with a different set of evidences (This optimization
%% is called inter-goal sharing, and unconditionally enabled in the
%% current PRISM system). An ad-hoc workaround is to introduce an
%% ID for each set of evidences and keep the ID through the arguments
%% (e.g. we define world(ID,E), msg_2_1(ID,L,B), and so on).
world(E):- assert_evid(E),msg_1_0.
msg_1_0 :- node_1(_L,_TL,_B).
msg_2_1(L,B) :- node_2(_S,L,B).
msg_3_1(L,TL):- node_3(_T,L,TL).
msg_4_3(T) :- node_4(_A,T).
msg_5_1(TL,B):- node_5(TL,B,_D).
msg_6_5(TL) :- node_6(TL,_X).
node_1(L,TL,B):-
msg_2_1(L,B),
msg_3_1(L,TL),
msg_5_1(TL,B).
node_2(S,L,B):-
cpt(s,[],S),
cpt(l,[S],L),
cpt(b,[S],B).
node_3(T,L,TL):-
incl_or(L,T,TL),
msg_4_3(T).
node_4(A,T):-
cpt(a,[],A),
cpt(t,[A],T).
node_5(TL,B,D):-
cpt(d,[TL,B],D),
msg_6_5(TL).
node_6(TL,X):-
cpt(x,[TL],X).
cpt(X,Par,V):-
( evid(X,V) -> true ; true ),
msw(bn(X,Par),V).
% inclusive OR
incl_or(t,t,t).
incl_or(t,f,t).
incl_or(f,t,t).
incl_or(f,f,f).
% adding evidences to Prolog database
assert_evid(Es):-
retractall(evid(_,_)),
assert_evid0(Es).
assert_evid0([]).
assert_evid0([(X,V)|Es]):-
assert(evid(X,V)),!,
assert_evid0(Es).
%%-------------------------------------
%% Utility part:
:- set_params.
set_params:-
set_sw(bn(a,[]),[0.01,0.99]),
set_sw(bn(t,[t]),[0.05,0.95]),
set_sw(bn(t,[f]),[0.01,0.99]),
set_sw(bn(s,[]),[0.5,0.5]),
set_sw(bn(l,[t]),[0.1,0.9]),
set_sw(bn(l,[f]),[0.01,0.99]),
set_sw(bn(x,[t]),[0.98,0.02]),
set_sw(bn(x,[f]),[0.05,0.95]),
set_sw(bn(b,[t]),[0.60,0.40]),
set_sw(bn(b,[f]),[0.30,0.70]),
set_sw(bn(d,[t,t]),[0.90,0.10]),
set_sw(bn(d,[t,f]),[0.70,0.30]),
set_sw(bn(d,[f,t]),[0.80,0.20]),
set_sw(bn(d,[f,f]),[0.10,0.90]).

7
packages/prism/exs/noisy_or/README Normal file
View File

@ -0,0 +1,7 @@
================== README (exs/noisy_or) ==========================
Files:
README ... this file
alarm_nor_basic.psm ... BN program using noisy OR (network-specific)
alarm_nor_generic.psm ... BN program using noisy OR (network-independent)
noisy_or.psm ... library for noisy OR

160
packages/prism/exs/noisy_or/alarm_nor_basic.psm Normal file
View File

@ -0,0 +1,160 @@
%%%%
%%%% Bayesian networks using noisy OR (1) -- alarm_nor_basic.psm
%%%%
%%%% Copyright (C) 2004,2006,2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This example is borrowed from:
%% Poole, D., Probabilistic Horn abduction and Bayesian networks,
%% In Proc. of Artificial Intelligence 64, pp.81-129, 1993.
%%
%% (Fire) (Tampering)
%% / \ /
%% ((Smoke)) (Alarm)
%% |
%% (Leaving) (( )) -- observable node
%% | ( ) -- hidden node
%% ((Report))
%%
%% In this network, we assume that all rvs (random variables) take on
%% {yes,no} and also assume that only two nodes, `Smoke' and `Report', are
%% observable.
%%
%% Furthermore, in this program, we consider that the Alarm variable's CPT
%% (conditional probability table) given through the noisy-OR rule. That is,
%% let us assume that we have the following inhibition probabilities:
%%
%% P(Alarm=no | Fire=yes, Tampering=no) = 0.3
%% P(Alarm=no | Fire=no, Tampering=yes) = 0.2
%%
%% The CPT for the Alarm variable is then constructed from these inhibition
%% probabilities and the noisy-OR rule:
%%
%% +------+-----------+--------------------+----------------+
%% | Fire | Tampering | P(Alarm=yes) | P(Alarm=no) |
%% +------+-----------+--------------------+----------------+
%% | yes | yes | 0.94 = 1 - 0.3*0.2 | 0.06 = 0.3*0.2 |
%% | yes | no | 0.7 = 1 - 0.3 | 0.3 |
%% | no | yes | 0.8 = 1 - 0.2 | 0.2 |
%% | no | no | 0 | 1.0 |
%% +------+-----------+--------------------+----------------+
%%
%% cpt_al/3 in this program implements the above CPT with random switches.
%% The key step is to consider the generation process underlying the noisy-OR
%% rule. One may notice that this program is written in a network-specific
%% form, but a more generic, network-independent program is given in
%% alarm_nor_generic.psm.
%%
%% Please note that this program shares a considerably large part with
%% ../alarm.psm, so some comments are omitted for simplicity.
%%-------------------------------------
%% Quick start:
%%
%% ?- prism(alarm_nor_basic).
%%
%% Print the CPT of the Alarm variable constructed from the noisy OR rule:
%% ?- print_dist_al.
%%
%% Print logical formulas that express the probabilistic behavior of
%% the noisy OR rule for Alarm:
%% ?- print_expl_al.
%%
%% Get the probability and the explanation graph:
%% ?- prob(world(yes,no)).
%% ?- probf(world(yes,no)).
%%
%% Get the most likely explanation and its probability:
%% ?- viterbif(world(yes,no)).
%% ?- viterbi(world(yes,no)).
%%
%% Compute conditional hindsight probabilities:
%% ?- chindsight(world(yes,no),world(_,_,_,_,_,_)).
%% ?- chindsight_agg(world(yes,no),world(_,_,query,yes,_,no)).
%%
%% Learn parameters from randomly generated 100 samples
%% ?- alarm_learn(100).
go:- alarm_learn(100).
%%-------------------------------------
%% Declarations:
values(_,[yes,no]).
%%------------------------------------
%% Modeling part:
world(Sm,Re):- world(_,_,_,Sm,_,Re).
world(Fi,Ta,Al,Sm,Le,Re) :-
cpt_fi(Fi), % P(Fire)
cpt_ta(Ta), % P(Tampering)
cpt_sm(Fi,Sm), % CPT P(Smoke | Fire)
cpt_al(Fi,Ta,Al), % CPT P(Alarm | Fire,Tampering)
cpt_le(Al,Le), % CPT P(Leaving | Alarm)
cpt_re(Le,Re). % CPT P(Report | Leaving)
cpt_fi(Fi):- msw(fi,Fi).
cpt_ta(Ta):- msw(ta,Ta).
cpt_sm(Fi,Sm):- msw(sm(Fi),Sm).
cpt_al(Fi,Ta,Al):- % implementation of noisy OR:
( Fi = yes, Ta = yes ->
msw(cause_al_fi,N_Al_Fi),
msw(cause_al_ta,N_Al_Ta),
( N_Al_Fi = no, N_Al_Ta = no -> Al = no
; Al = yes
)
; Fi = yes, Ta = no -> msw(cause_al_fi,Al)
; Fi = no, Ta = yes -> msw(cause_al_ta,Al)
; Fi = no, Ta = no -> Al = no
).
cpt_le(Al,Le):- msw(le(Al),Le).
cpt_re(Le,Re):- msw(re(Le),Re).
%%------------------------------------
%% Utility part:
alarm_learn(N) :-
unfix_sw(_), % Make all parameters changeable
set_params, % Set parameters as you specified
get_samples(N,world(_,_),Gs), % Get N samples
fix_sw(fi), % Preserve the parameter values
learn(Gs). % for {msw(fi,yes), msw(fi,no)}
set_params :-
set_sw(fi,[0.1,0.9]),
set_sw(ta,[0.15,0.85]),
set_sw(sm(yes),[0.95,0.05]),
set_sw(sm(no),[0.05,0.95]),
set_sw(le(yes),[0.88,0.12]),
set_sw(le(no),[0.01,0.99]),
set_sw(re(yes),[0.75,0.25]),
set_sw(re(no),[0.10,0.90]),
set_sw(cause_al_fi,[0.7,0.3]), % switch for an inhibition prob
set_sw(cause_al_ta,[0.8,0.2]). % switch for an inhibition prob
:- set_params.
%% Check routine for Noisy-OR
print_dist_al:-
set_params,
( member(Fi,[yes,no]),
member(Ta,[yes,no]),
member(Al,[yes,no]),
prob(cpt_al(Fi,Ta,Al),P),
format("P(al=~w | fi=~w, ta=~w):~t~6f~n",[Al,Fi,Ta,P]),
fail
; true
).
print_expl_al:-
set_params,
( member(Fi,[yes,no]),
member(Ta,[yes,no]),
member(Al,[yes,no]),
probf(cpt_al(Fi,Ta,Al)),
fail
; true
).

174
packages/prism/exs/noisy_or/alarm_nor_generic.psm Normal file
View File

@ -0,0 +1,174 @@
%%%%
%%%% Bayesian networks using noisy OR (2) -- alarm_nor_generic.psm
%%%%
%%%% Copyright (C) 2004,2006,2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This example is borrowed from:
%% Poole, D., Probabilistic Horn abduction and Bayesian networks,
%% In Proc. of Artificial Intelligence 64, pp.81-129, 1993.
%%
%% (Fire) (Tampering)
%% / \ /
%% ((Smoke)) (Alarm)
%% |
%% (Leaving) (( )) -- observable node
%% | ( ) -- hidden node
%% ((Report))
%%
%% In this network, we assume that all rvs (random variables) take on
%% {yes,no} and also assume that only two nodes, `Smoke' and `Report', are
%% observable.
%%
%% Furthermore, as did in alarm_nor_basic.psm, we consider that the Alarm
%% variable's CPT given through the noisy-OR rule. That is, we have the
%% following inhibition probabilities:
%%
%% P(Alarm=no | Fire=yes, Tampering=no) = 0.3
%% P(Alarm=no | Fire=no, Tampering=yes) = 0.2
%%
%% The CPT for the Alarm variable is then constructed from these inhibition
%% probabilities and the noisy-OR rule:
%%
%% +------+-----------+--------------------+----------------+
%% | Fire | Tampering | P(Alarm=yes) | P(Alarm=no) |
%% +------+-----------+--------------------+----------------+
%% | yes | yes | 0.94 = 1 - 0.3*0.2 | 0.06 = 0.3*0.2 |
%% | yes | no | 0.7 = 1 - 0.3 | 0.3 |
%% | no | yes | 0.8 = 1 - 0.2 | 0.2 |
%% | no | no | 0 | 1.0 |
%% +------+-----------+--------------------+----------------+
%%
%% While alarm_nor_basic.psm uses network-specific implementation, in this
%% program, we attempt to introduce a more generic routine that can handle
%% noisy OR. To be more concrete:
%%
%% - We specify noisy OR nodes in a declarative form (with noisy_or/3).
%% - We introduce generic probabilistic predicates that make probabilistic
%% choices, following the specifications of noisy OR nodes.
%%
%% The definition of these generic probabilistic predicates are given in
%% noisy_or.psm, and we will include noisy_or.psm into this program.
%%
%%-------------------------------------
%% Quick start (the same as those listed in alarm_nor_basic.psm):
%%
%% ?- prism(alarm_nor_generic).
%%
%% Print the CPT of the Alarm variable constructed from the noisy OR rule:
%% ?- print_dist_al.
%%
%% Print logical formulas that express the probabilistic behavior of
%% the noisy OR rule for Alarm:
%% ?- print_expl_al.
%%
%% Get the probability and the explanation graph:
%% ?- prob(world(yes,no)).
%% ?- probf(world(yes,no)).
%%
%% Get the most likely explanation and its probability:
%% ?- viterbif(world(yes,no)).
%% ?- viterbi(world(yes,no)).
%%
%% Compute conditional hindsight probabilities:
%% ?- chindsight(world(yes,no),world(_,_,_,_,_,_)).
%% ?- chindsight_agg(world(yes,no),world(_,_,query,yes,_,no)).
%%
%% Learn parameters from randomly generated 100 samples
%% ?- alarm_learn(100).
%%-------------------------------------
%% Declarations:
values(_,[yes,no]).
:- include('noisy_or.psm').
% We include generic probabilistic predicates that can handle
% noisy-OR. The following predicates will be available:
%
% - cpt(X,PaVs,V) represents a probabilistic choice where a
% random variable X given instantiations PaVs of parents
% takes a value V. If X is an ordinary node, a random
% switch bn(X,PaVs) will be used. On the other hand, if
% X is a noisy-OR node, switch cause(X,Y) will be used,
% where Y is one of parents of X.
%
% - set_nor_params/0 sets inhibition probabilisties (i.e.
% the parameters of switches cause(X,Y)) according to
% the specifications for noisy-OR nodes with noisy_or/3.
%%------------------------------------
%% Modeling part:
world(Sm,Re):- world(_,_,_,Sm,_,Re).
world(Fi,Ta,Al,Sm,Le,Re) :-
cpt(fi,[],Fi), % P(Fire)
cpt(ta,[],Ta), % P(Tampering)
cpt(sm,[Fi],Sm), % CPT P(Smoke | Fire)
cpt(al,[Fi,Ta],Al), % CPT P(Alarm | Fire,Tampering)
cpt(le,[Al],Le), % CPT P(Leaving | Alarm)
cpt(re,[Le],Re). % CPT P(Report | Leaving)
% declarations for noisy OR nodes:
noisy_or(al,[fi,ta],[[0.7,0.3],[0.8,0.2]]).
%%------------------------------------
%% Utility part:
alarm_learn(N) :-
unfix_sw(_), % Make all parameters changeable
set_params, % Set ordinary parameters
set_nor_params, % Set inhibition parameters
get_samples(N,world(_,_),Gs), % Get N samples
fix_sw(bn(fi,[])), % Preserve the parameter values
learn(Gs). % for {msw(bn(fi,[]),yes), msw(bn(fi,[]),no)}
:- set_params.
:- set_nor_params.
set_params:-
set_sw(bn(fi,[]),[0.1,0.9]),
set_sw(bn(ta,[]),[0.15,0.85]),
set_sw(bn(sm,[yes]),[0.95,0.05]),
set_sw(bn(sm,[no]),[0.05,0.95]),
set_sw(bn(le,[yes]),[0.88,0.12]),
set_sw(bn(le,[no]),[0.01,0.99]),
set_sw(bn(re,[yes]),[0.75,0.25]),
set_sw(bn(re,[no]),[0.10,0.90]).
%% Check routine for Noisy-OR
print_dist_al:-
( member(Fi,[yes,no]),
member(Ta,[yes,no]),
member(Al,[yes,no]),
get_cpt_prob(al,[Fi,Ta],Al,P),
format("P(al=~w | fi=~w, ta=~w):~t~6f~n",[Al,Fi,Ta,P]),
fail
; true
).
print_expl_al:-
( member(Fi,[yes,no]),
member(Ta,[yes,no]),
member(Al,[yes,no]),
get_cpt_probf(al,[Fi,Ta],Al),
fail
; true
).
%% [Note] prob/1 and probf/1 will fail if its argument fails
get_cpt_prob(X,PaVs,V,P):-
( prob(cpt(X,PaVs,V),P)
; P = 0.0
),!.
get_cpt_probf(X,PaVs,V):-
( probf(cpt(X,PaVs,V))
; format("cpt(~w,~w,~w): always false~n",[X,PaVs,V])
),!.

65
packages/prism/exs/noisy_or/noisy_or.psm Normal file
View File

@ -0,0 +1,65 @@
%%%%
%%%% Library for generic noisy OR predicates --- noisy_or.psm
%%%%
%%%% Copyright (C) 2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% When this file included, the following predicates will be available:
%%
%% - cpt(X,PaVs,V) represents a probabilistic choice where a
%% random variable X given instantiations PaVs of parents
%% takes a value V. If X is an ordinary node, a random
%% switch bn(X,PaVs) will be used. On the other hand, if
%% X is a noisy-OR node, switch cause(X,Y) will be used,
%% where Y is one of parents of X.
%%
%% - set_nor_params/0 sets inhibition probabilisties (i.e.
%% the parameters of switches cause(X,Y)) according to
%% the specifications for noisy-OR nodes with noisy_or/3.
%%---------------------------------------
%% Declarations:
% added just for making the results of probabilistic inference
% simple and readable:
:- p_not_table choose_noisy_or/4, choose_noisy_or/6.
%%---------------------------------------
%% Modeling part:
cpt(X,PaVs,V):-
( noisy_or(X,Pa,_) -> choose_noisy_or(X,Pa,PaVs,V) % for noisy OR nodes
; msw(bn(X,PaVs),V) % for ordinary nodes
).
choose_noisy_or(X,Pa,PaVs,V):- choose_noisy_or(X,Pa,PaVs,no,no,V).
choose_noisy_or(_,[],[],yes,V,V).
choose_noisy_or(_,[],[],no,_,no).
choose_noisy_or(X,[Y|Pa],[PaV|PaVs],PaHasYes0,ValHasYes0,V):-
( PaV=yes ->
msw(cause(X,Y),V0),
PaHasYes=yes,
( ValHasYes0=no, V0=no -> ValHasYes=no
; ValHasYes=yes
)
; PaHasYes=PaHasYes0,
ValHasYes=ValHasYes0
), % do not insert the cut symbol here
choose_noisy_or(X,Pa,PaVs,PaHasYes,ValHasYes,V).
%%---------------------------------------
%% Utility part:
set_nor_params:-
( noisy_or(X,Pa,DistList), % spec for a noisy OR node
set_nor_params(X,Pa,DistList),
fail
; true
).
set_nor_params(_,[],[]).
set_nor_params(X,[Y|Pa],[Dist|DistList]):-
set_sw(cause(X,Y),Dist),!,
set_nor_params(X,Pa,DistList).

89
packages/prism/exs/pdcg.psm Normal file
View File

@ -0,0 +1,89 @@
%%%%
%%%% Probabilistic DCG --- pdcg.psm
%%%%
%%%% Copyright (C) 2004,2006,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% PCFGs (probabilistic contex free grammars) are a stochastic extension
%% of CFG grammar such that in a (leftmost) derivation, each production
%% rule is selected probabilistically and applied. Look at the following
%% sample PCFG in which S is a start symbol and {a,b} are terminals.
%%
%% Rule 1: S -> SS (0.4)
%% Rule 2: S -> a (0.5)
%% Rule 3: S -> b (0.1)
%%
%% When S is expanded, three rules, Rule 1, 2 and 3 are applicable.
%% To determine a rule to apply, probabilistic selection is made in
%% such a way that Rule 1 is selected with probability 0.4, Rule 2
%% with probability 0.5 and Rule 3 with probability 0.1, respectively.
%% The probability of a derivation tree is defined to be the product
%% of probabilities associated with rules used in the derivation,
%% and that of a sentence is defined to be the sum of proabibities of
%% derivations for the sentence.
%%
%% When modeling PCFGs, we follow DCG (definite clause grammar)
%% formalism. So we write down a top-down parser using difference
%% list which represents the rest of the sentence to parse. Note that
%% the grammar is left-recursive, and hence running the program below
%% without a tabling mechanism goes into an infinite loop.
%%-------------------------------------
%% Quick start : learning experiment with the sample grammar
%%
%% ?- prism(pdcg),go. % Learn parameters of the PCFG above from
%% % randomly generated 100 samples
%%
%% ?- prob(pdcg([a,b,b])).
%% ?- prob(pdcg([a,b,b]),P).
%% ?- probf(pdcg([a,b,b])).
%% ?- probf(pdcg([a,b,b]),E),print_graph(E).
%% ?- sample(pdcg(X)).
%%
%% ?- viterbi(pdcg([a,b,b]),P). % P is the prob. of the most likely
%% ?- viterbif(pdcg([a,b,b]),P,E). % explanation E for pdcg([a,b,b])
%% ?- viterbif(pdcg([a,b,b]),P,E),print_graph(E).
go:- pdcg_learn(100).
max_str_len(20). % Maximum string length is 20.
%%------------------------------------
%% Declarations:
values('S',[['S','S'],a,b],[0.4,0.5,0.1]).
% We use a msw of the form msw('S',V) such
% that V is one of { ['S','S'], a, b },
% and when msw('S',V) is executed, the prob.
% of V=['S','S'] is 0.4, that of V=a is 0.5
% and that of V=b is 0.1.
%%------------------------------------
%% Modeling part:
start_symbol('S'). % Start symbol is S
pdcg(L):-
start_symbol(I),
pdcg2(I,L-[]).
% I is a category to expand.
pdcg2(I,L0-L2):- % L0-L2 is a list for I to span.
msw(I,RHS), % Choose a rule I -> RHS probabilistically.
( RHS == ['S','S'],
pdcg2('S',L0-L1),
pdcg2('S',L1-L2)
; RHS == a,
L0 = [RHS | L2]
; RHS == b,
L0 = [RHS | L2] ).
%%------------------------------------
%% Utility part:
pdcg_learn(N):-
max_str_len(MaxStrL),
get_samples_c(N,pdcg(X),(length(X,Y),Y =< MaxStrL),Goals,[Ns,_]),
format("#sentences= ~d~n",[Ns]),
unfix_sw('S'), % Make parameters of msw('S',.) changable
learn(Goals). % Conduct ML estimation by graphical EM learning

121
packages/prism/exs/pdcg_c.psm Normal file
View File

@ -0,0 +1,121 @@
%%%%
%%%% Probabilistic DCG for Charniak's example --- pdcg_c.psm
%%%%
%%%% Copyright (C) 2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% As described in the comments in pdcg.psm, PCFGs (probabilistic context-
%% free grammars) are a stochastic extension of CFG grammar such that in a
%% (leftmost) derivation, each production rule is selected probabilistically
%% and applied. This program presents an implementation of an example from
%% Charniak's textbook (Statistical Language Learning, The MIT Press, 1993):
%%
%% s --> np vp (0.8) | verb --> swat (0.2)
%% s --> vp (0.2) | verb --> flies (0.4)
%% np --> noun (0.4) | verb --> like (0.4)
%% np --> noun pp (0.4) | noun --> swat (0.05)
%% np --> noun np (0.2) | noun --> flies (0.45)
%% vp --> verb (0.3) | noun --> ants (0.5)
%% vp --> verb np (0.3) | prep --> like (1.0)
%% vp --> verb pp (0.2) |
%% vp --> verb np pp (0.2) |
%% pp --> prep np (1.0) |
%% (`s' is the start symbol)
%%
%% This program has a grammar-independent part (pcfg/1-2 and proj/2),
%% which can work with any underlying CFG which has no epsilon rules
%% and produces no unit cycles.
%%----------------------------------
%% Quick start:
%%
%% ?- prism(pdcg_c).
%%
%% ?- prob(pcfg([swat,flies,like,ants])).
%% % get the generative probability of a sentence
%% % "swat flies like ants"
%%
%% ?- sample(pcfg(_X)),viterbif(pcfg(_X)).
%% % parse a sampled sentence
%%
%% ?- get_samples(50,pcfg(X),_Gs),learn(_Gs),show_sw.
%% % conduct an artificial learning experiments
%%
%% ?- viterbif(pcfg([swat,flies,like,ants])).
%% % get the most probabile parse for "swat flies like ants"
%%
%% ?- n_viterbif(3,pcfg([swat,flies,like,ants])).
%% % get top 3 ranked parses for "swat flies like ants"
%%
%% ?- viterbit(pcfg([swat,flies,like,ants])).
%% % print the most probabile parse for "swat flies like ants" in
%% % a tree form.
%%
%% ?- viterbit(pcfg([swat,flies,like,ants]),P,E), build_tree(E,T).
%% % get the most probabile parse for "swat flies like ants" in a
%% % tree form, and convert it to a more readable Prolog term.
%%
%% ?- probfi(pcfg([swat,flies,like,ants])).
%% % print the parse forest with inside probabilities
%%
%%----------------------------------
%% Declarations:
values(s,[[np,vp],[vp]]).
values(np,[[noun],[noun,pp],[noun,np]]).
values(vp,[[verb],[verb,np],[verb,pp],[verb,np,pp]]).
values(pp,[[prep,np]]).
values(verb,[[swat],[flies],[like]]).
values(noun,[[swat],[flies],[ants]]).
values(prep,[[like]]).
:- p_not_table proj/2. % This declaration is introduced just for
% making the results of probabilistic inferences
% simple and readable.
%%----------------------------------
%% Modeling part:
pcfg(L):- pcfg(s,L-[]).
pcfg(LHS,L0-L1):-
( nonterminal(LHS) -> msw(LHS,RHS),proj(RHS,L0-L1)
; L0 = [LHS|L1]
).
proj([],L-L).
proj([X|Xs],L0-L1):-
pcfg(X,L0-L2),proj(Xs,L2-L1).
nonterminal(s).
nonterminal(np).
nonterminal(vp).
nonterminal(pp).
nonterminal(verb).
nonterminal(noun).
nonterminal(prep).
%%----------------------------------
%% Utility part:
% set the rule probabilities:
:- set_sw(s,[0.8,0.2]).
:- set_sw(np,[0.4,0.4,0.2]).
:- set_sw(vp,[0.3,0.3,0.2,0.2]).
:- set_sw(pp,[1.0]).
:- set_sw(verb,[0.2,0.4,0.4]).
:- set_sw(noun,[0.05,0.45,0.5]).
:- set_sw(prep,[1.0]).
% build_tree(E,T):-
% Build a parse tree T from a tree-formed explanation E.
build_tree([],[]).
build_tree([pcfg(_),Gs],T) :- build_tree(Gs,T).
build_tree([pcfg(Sym,_)|Gs],T) :- build_tree1(Gs,T0),T=..[Sym|T0].
build_tree1([],[]).
build_tree1([pcfg(Sym,_)|Gs],[Sym|T]) :- !,build_tree1(Gs,T).
build_tree1([msw(_,_)|Gs],T) :- !, build_tree1(Gs,T).
build_tree1([G|Gs],[T0|T]) :- build_tree(G,T0),!,build_tree1(Gs,T).

44
packages/prism/exs/phmm.dat Normal file
View File

@ -0,0 +1,44 @@
%% This data was created by Rose.
%% see http://bibiserv.techfak.uni-bielefeld.de/rose
%% Rose
%% Copyright (c) 1997-2000 University of Bielefeld, Germany and
%% Deutsches Krebsforschungszentrum (DKFZ) Heidelberg, Germany.
%% All rights reserved.
%%
%% correct alignments
%%
%% HLKIANRKDK----HHNKEFGGHHLA
%% HLKATHRKDQ----HHNREFGGHHLA
%% VLKFANRKSK----HHNKEMGAHHLA
%% HKKGAT---------------PVNVS
%% HKKGATATG-----------NPKHVC
%% QFKVAAAVGK----HQDASRGVHHID
%% SFKGQGAVSK----HQDPEWGVHHID
%% SFKGQGAVSV----PQAPAWGINHID
%% HFKSQAEVNK----HDRPEWGLNQID
%% HFRSQAEVNQRQFNHHRPQWSFNQIG
%% SFNVVKGASK----RENGGMGAEPVD
%% KFKKVDGLGK----KEHPALGVH---
%% KFMVGGKDGK----NRKDAHAHRKVE
%% KYKVPEKDGK----KRTNAHSHRKVE
%% RYKIPESDGK----KRTNSHRHRKVE
%% RYKIASMDGK----KRYAEHKHKKLE
observe( ['H','L','K','I','A','N','R','K','D','K','H','H','N','K','E','F','G','G','H','H','L','A'] ).
observe( ['H','L','K','A','T','H','R','K','D','Q','H','H','N','R','E','F','G','G','H','H','L','A'] ).
observe( ['V','L','K','F','A','N','R','K','S','K','H','H','N','K','E','M','G','A','H','H','L','A'] ).
observe( ['H','K','K','G','A','T','P','V','N','V','S'] ).
observe( ['H','K','K','G','A','T','A','T','G','N','P','K','H','V','C'] ).
observe( ['Q','F','K','V','A','A','A','V','G','K','H','Q','D','A','S','R','G','V','H','H','I','D'] ).
observe( ['S','F','K','G','Q','G','A','V','S','K','H','Q','D','P','E','W','G','V','H','H','I','D'] ).
observe( ['S','F','K','G','Q','G','A','V','S','V','P','Q','A','P','A','W','G','I','N','H','I','D'] ).
observe( ['H','F','K','S','Q','A','E','V','N','K','H','D','R','P','E','W','G','L','N','Q','I','D'] ).
observe( ['H','F','R','S','Q','A','E','V','N','Q','R','Q','F','N','H','H','R','P','Q','W','S','F','N','Q','I','G'] ).
observe( ['S','F','N','V','V','K','G','A','S','K','R','E','N','G','G','M','G','A','E','P','V','D'] ).
observe( ['K','F','K','K','V','D','G','L','G','K','K','E','H','P','A','L','G','V','H'] ).
observe( ['K','F','M','V','G','G','K','D','G','K','N','R','K','D','A','H','A','H','R','K','V','E'] ).
observe( ['K','Y','K','V','P','E','K','D','G','K','K','R','T','N','A','H','S','H','R','K','V','E'] ).
observe( ['R','Y','K','I','P','E','S','D','G','K','K','R','T','N','S','H','R','H','R','K','V','E'] ).
observe( ['R','Y','K','I','A','S','M','D','G','K','K','R','Y','A','E','H','K','H','K','K','L','E'] ).

263
packages/prism/exs/phmm.psm Normal file
View File

@ -0,0 +1,263 @@
%%%%
%%%% Profile HMM --- phmm.psm
%%%%
%%%% Copyright (C) 2004,2006,2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% Profile HMMs are a variant of HMMs that have three types of states,
%% i.e. `match state',`insert state' and `delete state.' Match states
%% constitute an HMM that outputs a `true' string. Insertion states
%% emit a symbol additionally to the `true' string whereas delete (skip)
%% states emit no symbol.
%%
%% Profile HMMs are used to align amino-acid sequences by inserting
%% and skipping symbols as well as matching symbols. For example
%% amino-acid sequences below
%%
%% HLKIANRKDKHHNKEFGGHHLA
%% HLKATHRKDQHHNREFGGHHLA
%% VLKFANRKSKHHNKEMGAHHLA
%% ...
%%
%% are aligned by the profile HMM program in this file as follows.
%%
%% -HLKIA-NRKDK-H-H----NKEFGGHH-LA
%% -HLK-A-T-HRK-DQHHN--R-EFGGHH-LA
%% -VLKFA-NRKSK-H-H----NKEMGAHH-LA
%% ...
%%-------------------------------------
%% Quick start : sample session, align the sample data in phmm.dat.
%%
%% To run on an interactive session:
%% ?- prism(phmm),go. (ML/MAP)
%% ?- prism(phmm),go_vb. (variational Bayes)
%%
%% To perform a batch execution:
%% > upprism phmm
go :-
read_goals(Gs,'phmm.dat'), % Read the sequence data from phmm.dat.
learn(Gs), % Learn parameters from the data.
wmag(Gs). % Compute viterbi paths using the learned
% parameters and aligns sequences in Gs.
% To enable variational Bayes, we need some additional flag settings:
go_vb :-
set_prism_flag(learn_mode,both),
set_prism_flag(viterbi_mode,hparams),
set_prism_flag(reset_hparams,on),
go.
prism_main :- go.
%prism_main :- go_vb.
%%%--------------------- model ---------------------
observe(Sequence) :- hmm(Sequence,start).
hmm([],end).
hmm(Sequence,State) :-
State \== end,
msw(move_from(State),NextState),
msw(emit_at(State), Symbol),
( Symbol = epsilon ->
hmm( Sequence, NextState )
; Sequence = [Symbol|TailSeq],
hmm( TailSeq , NextState )
).
amino_acids(['A','C','D','E','F','G','H','I','K','L','M','N','P','Q','R',
'S','T','V','W','X','Y']).
hmm_len(17).
%%%--------------------- values ---------------------
values(move_from(State),Values) :-
hmm_len(Len),
get_index(State,X),
( 0 =< X, X < Len ->
Y is X + 1,
Values = [insert(X),match(Y),delete(Y)]
; Values = [insert(X),end] ).
values(emit_at(State),Vs) :-
((State = insert(_) ; State = match(_)) ->
amino_acids(Vs)
; Vs = [epsilon] ).
%%%--------------------- set_sw ---------------------
:- init_set_sw.
init_set_sw :-
% tell('/dev/null'), % Suppress output (on Linux only)
set_sw( move_from(start) ),
set_sw( move_from(insert(0)) ),
set_sw( emit_at(start) ),
set_sw( emit_at(insert(0)) ),
hmm_len(Len),
% told,
init_set_sw(Len).
init_set_sw(0).
init_set_sw(X) :-
X > 0,
set_sw( move_from(insert(X)) ),
set_sw( move_from(match(X)) ),
set_sw( move_from(delete(X)) ),
set_sw( emit_at(insert(X)) ),
set_sw( emit_at(match(X)) ),
set_sw( emit_at(delete(X)) ),
Y is X - 1,
init_set_sw(Y).
%%%--------------------- estimation ---------------------
%% most likely path
%% mlpath(['A','E'],Path) => Path = [start,match(1),end]
mlpath(Sequence,Path):-
mlpath(Sequence,Path,_).
mlpath(Sequence,Path,Prob):-
viterbif(hmm(Sequence,start),Prob,Nodes),
nodes2path(Nodes,Path).
nodes2path([Node|Nodes],[State|Path]):-
Node = node(hmm(_,State),_),
nodes2path(Nodes,Path).
nodes2path([],[]).
mlpaths([Seq|Seqs],[Path|Paths], X):-
mlpath(Seq,Path),
X= [P|_], writeln(P),
stop_low_level_trace,
mlpaths(Seqs,Paths, X).
mlpaths([],[],_).
%%%--------------------- alignment ---------------------
wmag(Gs):-
seqs2goals(S,Gs),wma(S).
wma(Seqs):-
write_multiple_alignments(Seqs).
write_multiple_alignments(Seqs):-
nl,
write('search Viterbi paths...'),nl,
mlpaths(Seqs,Paths,Paths),
write('done.'),
nl,
write('------------ALIGNMENTS------------'),
nl,
write_multiple_alignments( Seqs, Paths ),
write('----------------------------------'),
nl.
make_max_length_list([Path|Paths],MaxLenList) :-
make_max_length_list(Paths, TmpLenList),
make_length_list(Path,LenList),
marge_len_list(LenList,TmpLenList,MaxLenList).
make_max_length_list([Path],MaxLenList) :-
!,make_length_list(Path,MaxLenList).
marge_len_list([H1|T1],[H2|T2],[MargedH|MargedT]) :-
max(MargedH,[H1,H2]),
marge_len_list(T1,T2,MargedT).
marge_len_list([],[],[]).
%% make_length_list([start,insert(0),match(1),end],LenList)
%% -> LenList = [2,1]
%% make_length_list([start,delete(1),insert(1),insert(1),end],LenList)
%% -> LenList = [1,1]
make_length_list(Path,[Len|LenList]) :-
count_emission(Path,Len,NextIndexPath),
make_length_list(NextIndexPath,LenList).
make_length_list([end],[]).
count_emission(Path,Count,NextIndexPath) :-
Path = [State|_],
get_index(State,Index),
count_emission2(Path,Count,Index,NextIndexPath).
%% count_emission2([start,insert(0),match(1),end],Count,0,NextIndexPath)
%% -> Count = 2, NextIndexPath = [match(1),end]
%% count_emission2([delete(1),insert(1),insert(1),end],Count,1,NextIndexPath)
%% -> Count = 2, NextIndexPath = [end]
count_emission2([State|Path],Count,Index,NextIndexPath) :-
( get_index(State,Index) ->
count_emission2( Path, Count2, Index, NextIndexPath ),
( (State = delete(_); State==start) ->
Count = Count2
; Count is Count2 + 1 )
; Count = 0,
NextIndexPath = [State|Path]
).
write_multiple_alignments(Seqs,Paths) :-
make_max_length_list(Paths,LenList),
write_multiple_alignments(Seqs,Paths,LenList).
write_multiple_alignments([Seq|Seqs],[Path|Paths],LenList) :-
write_alignment(Seq,Path,LenList),
write_multiple_alignments(Seqs,Paths,LenList).
write_multiple_alignments([],[],_).
write_alignment(Seq,Path,LenList) :-
write_alignment(Seq,Path,LenList,0).
write_alignment([],[end],[],_):- !,nl.
write_alignment(Seq,[State|Path],LenList,Index) :-
get_index(State,Index),!,
( (State = delete(_) ; State == start) ->
write_alignment( Seq, Path, LenList, Index )
; Seq = [Symbol|Seq2],
LenList = [Len|LenList2],
write(Symbol),
Len2 is Len - 1,
write_alignment(Seq2,Path,[Len2|LenList2],Index)
).
write_alignment(Seq,[State|Path],LenList,Index) :-
LenList = [Len|LenList2],
Index2 is Index + 1,
pad(Len),
write_alignment(Seq,[State|Path],LenList2,Index2).
pad(Len) :-
Len > 0,
write('-'),
Len2 is Len - 1,!,
pad(Len2).
pad(0).
%%%--------------------- utility ---------------------
get_index(State,Index) :-
(State=match(_),!,State=match(Index));
(State=insert(_),!,State=insert(Index));
(State=delete(_),!,State=delete(Index));
(State=start,!,Index=0);
(State=end,!,hmm_len(X),Index is X+1).
seqs2goals([Seq|Seqs],[Goal|Goals]) :-
Goal = observe(Seq),
seqs2goals(Seqs,Goals).
seqs2goals([],[]).
max(Max,[Head|Tail]) :-
max(Tmp,Tail),!,
( Tmp > Head -> Max = Tmp ; Max = Head ).
max(Max,[Max]).
read_goals(Goals,FileName) :-
see(FileName),
read_goals(Goals),
seen.
read_goals(Goals) :-
read(Term),
( Term = end_of_file ->
Goals = []
; Goals = [Term|Goals1],
read_goals(Goals1)
).

60
packages/prism/exs/plc.dat Normal file
View File

@ -0,0 +1,60 @@
pslc([adv,n,p,v,n,adv,adv,adv,adv,v,n,p,v]).
pslc([v,n,c,v,n,p,v,n,c,n,p,v]).
pslc([adv,n,p,v,n,adv,adv,v,n,p,v,n,c,v,n,p,v,n,p,v]).
pslc([n,p,v]).
pslc([n,p,v]).
pslc([adv,adv,v,n,p,v,n,c,adv,adv,v,n,p,v,n,p,v]).
pslc([n,p,v]).
pslc([n,p,v]).
pslc([adv,adv,n,c,n,p,v,n,p,v,n,p,v,n,p,v,n,p,v]).
pslc([n,p,v]).
pslc([n,p,v]).
pslc([adv,adv,v,n,c,adv,v,n,p,v]).
pslc([n,p,v]).
pslc([v,n,c,adv,v,n,c,n,p,v,n,p,v]).
pslc([v,n,c,n,c,v,n,p,v]).
pslc([adv,adv,v,n,c,adv,v,n,c,adv,n,p,v,n,c,n,p,v,n,v,n,p,v]).
pslc([n,p,v]).
pslc([adv,n,p,v,n,c,v,n,p,v,n,v,n,p,v]).
pslc([v,n,c,n,p,v,n,p,v]).
pslc([n,c,v,n,c,n,c,n,p,v,n,p,v,n,p,v]).
pslc([v,n,c,n,p,v,n,c,adv,adv,v,n,p,v]).
pslc([adv,adv,v,n,c,v,n,p,v]).
pslc([n,p,v,n,c,adv,v,n,v,n,p,v]).
pslc([v,n,c,n,p,v,n,c,v,n,p,v]).
pslc([n,p,v]).
pslc([adv,adv,v,n,p,v,n,p,v]).
pslc([n,p,v]).
pslc([v,n,p,v]).
pslc([adv,adv,adv,n,p,v,n,p,v,n,c,v,n,v,n,c,v,n,p,v,n,c,n,p,v,n,c,n,p,v]).
pslc([v,n,p,v,n,p,v]).
pslc([v,n,p,v]).
pslc([n,c,n,p,v,n,p,v]).
pslc([n,p,v]).
pslc([adv,adv,v,n,v,n,c,adv,v,n,n,p,v,n,c,n,c,n,p,v,n,p,v,n,p,v]).
pslc([n,p,v]).
pslc([n,p,v,n,p,v]).
pslc([adv,n,adv,adv,v]).
pslc([adv,v,n,p,v,n,v,n,c,v,n,c,v,n,c,n,p,v,n,p,v,n,c,v,n,c,v,n,p,v]).
pslc([adv,adv,v,n,p,v,n,c,v,n,c,v,n,c,adv,v,n,p,v,n,p,v,n,p,v]).
pslc([n,p,v,n,p,v,n,p,v]).
pslc([n,p,v,n,c,adv,adv,v,n,p,v,n,v,n,p,v]).
pslc([adv,v,n,p,v,n,p,v]).
pslc([adv,adv,v,n,p,v]).
pslc([adv,adv,v,n,p,v,n,p,v]).
pslc([v,n,p,v]).
pslc([adv,n,p,v,n,c,adv,adv,v,n,v,n,n,p,v]).
pslc([n,p,v]).
pslc([adv,n,p,v,n,p,v]).
pslc([adv,n,p,v,n,adv,adv,v,n,c,n,p,v,n,p,v,n,c,v,n,p,v]).
pslc([n,p,v]).
pslc([n,c,v,n,c,n,p,v,n,c,adv,v,n,v,n,p,v]).
pslc([n,p,v,n,p,v,n,p,v,n,p,v]).
pslc([v,n,p,v,n,p,v]).
pslc([v,n,c,adv,v,n,c,n,p,v,n,p,v,n,c,adv,adv,v,n,p,v,n,p,v]).
pslc([n,p,v]).
pslc([v,n,p,v,n,p,v,n,c,adv,adv,v,n,p,v,n,v,n,p,v,n,p,v,n,p,v,n,p,v]).
pslc([v,n,p,v]).
pslc([n,p,v]).
pslc([n,c,adv,adv,v,n,p,v]).
pslc([n,p,v]).

215
packages/prism/exs/plc.psm Normal file
View File

@ -0,0 +1,215 @@
%%%%
%%%% Probablistic left corner grammar --- plc.psm
%%%%
%%%% Copyright (C) 2004,2006,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This is a PRISM program modeling a probabilistic left-corner
%% parser (stack version) described in
%%
%% "Probabilistic Parsing using left corner language models",
%% C.D.Manning,
%% Proc. of the 5th Int'l Conf. on Parsing Technologies (IWPT-97),
%% MIT Press, pp.147-158.
%%
%% Note that this program defines a distribution over sentences
%% procedurally, i.e. the derivation process is described in terms
%% of stack operations. Also note that we automatically get
%% a correctness-guaranteed EM procedure for probablistic
%% left-corner grammars.
%%-------------------------------------
%% Quick start : sample session with Grammar_1 (attached below)
%%
%% (1) Move to a directory where this program is placed.
%% (2) Start PRISM (no options needed since 1.10)
%%
%% > prism
%%
%% (3) Load this program (by default, every msw is given a uniform
%% distribution)
%%
%% ?- prism(plc).
%%
%% (4) Use uitilities, e.g.
%% (4-1) Computing explanation (support) graphs and probabilities
%%
%% ?- prob(pslc([n,p,v])).
%% ?- probf(pslc([n,p,v])).
%% ?- probf(pslc([n,p,v]),E),print_graph(E).
%% ?- prob(pslc([adv,adv,n,c,n,p,v])).
%% ?- probf(pslc([adv,adv,n,c,n,p,v])).
%% ?- probf(pslc([adv,adv,n,c,n,p,v]),E),print_graph(E).
%%
%% Pv is prob. of a most likely explanation E for pslc([adv,...,v])
%% ?- viterbif(pslc([adv,adv,n,c,n,p,v]),Pv,E).
%% ?- viterbi(pslc([adv,adv,n,c,n,p,v]),Pv).
%%
%% (4-2) Sampling
%%
%% ?- sample(pslc(X)), sample(pslc(Y)), sample(pslc(Z)).
%%
%% (4-3) Graphical EM learning for Grammar_1 (wait for some time)
%%
%% ?- go.
go:- plc_learn(50). % Generate randomly 50 sentences and learn
max_str_len(30). % Sentence length <= 30
%%------------------------------------
%% Modeling part:
pslc(Ws) :-
start_symbol(C), % asserted in Grammar_1
pslc(Ws,[g(C)]). % C is a top-goal category
pslc([],[]).
pslc(L0,Stack0) :-
process(Stack0,Stack,L0,L),
pslc(L,Stack).
%% shift operation
process([g(A)|Rest],Stack,[Wd|L],L):- % g(A) is a goal category
( terminal(A), % Stack given = [g(A),g(F),D...] created
A = Wd, Stack = Rest % by e.g. projection using E -> D,A,F
; \+ terminal(A), % Select probabilistically one of first(A)
( get_values(first(A),[Wd]) % No choice if the first set is a singleton
; get_values(first(A),[_,_|_]), % Select 1st word by msw
msw(first(A),Wd) ),
Stack = [Wd,g(A)|Rest]
).
%% projection and attachment
process([A|Rest],Stack,L,L):- % a subtree with top=A is completed
\+ A = g(_), % A's right neighbor has the form g(_)
Rest = [g(C)|Stack0], % => A is not a terminal
( A == C, % g(A) is waiting for an A-tree
( get_values(lc(A,A),_), % lc(X,Y) means X - left-corner -> Y
msw(attach(A),Op), % A must have a chance of not attaching
( Op == attach, Stack = Stack0 % attachment
; Op == project, next_Stack(A,Rest,Stack) ) % projection
; \+ get_values(lc(A,A),_),
Stack = Stack0 ) % forcible attachment for nonterminal
; A \== C,
next_Stack(A,Rest,Stack) ).
%% projection % subtree A completed, waited for by g(C)
next_Stack(A,[g(C)|Rest2],Stack) :- % rule I -> A J K
( get_values(lc(C,A),[_,_|_]), % => Stack=[g(J),g(K),I,g(C)...]
msw(lc(C,A),rule(LHS,[A|RHS2])) % if C - left-corner -> A
; get_values(lc(C,A),[rule(LHS,[A|RHS2])]) ), % no other rules for projection
predict(RHS2,[LHS,g(C)|Rest2],Stack).
predict([],L,L).
predict([A|Ls],L2,[g(A)|NewLs]):-
predict(Ls,L2,NewLs).
%%------------------------------------
%% Utility part:
plc_learn(N):-
gen_plc(N,Goals),
learn(Goals).
gen_plc(0,[]).
gen_plc(N,Goals):-
N > 0,
N1 is N-1,
sample(pslc(L)),
length(L,K),
max_str_len(StrL),
( K > StrL,
Goals = G2
; Goals=[pslc(L)|G2],
format(" G = ~w~n",[pslc(L)])
),!,
gen_plc(N1,G2).
%%--------------- Grammar_1 -----------------
start_symbol(s).
rule(s,[pp,v]).
rule(s,[ap,vp]).
rule(vp,[pp,v]).
rule(vp,[ap,v]).
rule(np,[vp,n]).
rule(np,[v,n]).
rule(np,[n]).
rule(np,[np,c,np]).
rule(np,[ap,np]).
rule(pp,[np,p]).
rule(pp,[n,p]).
rule(ap,[adv,adv]).
rule(ap,[adv]).
rule(ap,[adv,np]).
terminal(v).
terminal(n).
terminal(c).
terminal(p).
terminal(adv).
%% first set computed from Grammar_1
first(vp,v).
first(np,v).
first(pp,v).
first(s,v).
first(vp,n).
first(np,n).
first(pp,n).
first(s,n).
first(vp,adv).
first(ap,adv).
first(np,adv).
first(pp,adv).
first(s,adv).
%%------------------------------------
%% Declarations:
%%
%% created from Grammar_1
values(lc(s,pp),[rule(s,[pp,v]),rule(vp,[pp,v])]).
values(lc(s,np),[rule(np,[np,c,np]),rule(pp,[np,p])]).
values(lc(s,vp),[rule(np,[vp,n])]).
values(lc(pp,np),[rule(np,[np,c,np]),rule(pp,[np,p])]).
values(lc(pp,vp),[rule(np,[vp,n])]).
values(lc(pp,pp),[rule(vp,[pp,v])]).
values(lc(np,vp),[rule(np,[vp,n])]).
values(lc(np,pp),[rule(vp,[pp,v])]).
values(lc(np,np),[rule(np,[np,c,np]),rule(pp,[np,p])]).
values(lc(vp,pp),[rule(vp,[pp,v])]).
values(lc(vp,np),[rule(np,[np,c,np]),rule(pp,[np,p])]).
values(lc(vp,vp),[rule(np,[vp,n])]).
values(lc(vp,ap),[rule(np,[ap,np]),rule(vp,[ap,v])]).
values(lc(vp,adv),[rule(ap,[adv]),rule(ap,[adv,adv]),rule(ap,[adv,np])]).
values(lc(ap,adv),[rule(ap,[adv]),rule(ap,[adv,adv]),rule(ap,[adv,np])]).
values(lc(vp,v),[rule(np,[v,n])]).
values(lc(vp,n),[rule(np,[n]),rule(pp,[n,p])]).
values(lc(np,v),[rule(np,[v,n])]).
values(lc(np,n),[rule(np,[n]),rule(pp,[n,p])]).
values(lc(np,ap),[rule(np,[ap,np]),rule(vp,[ap,v])]).
values(lc(np,adv),[rule(ap,[adv]),rule(ap,[adv,adv]),rule(ap,[adv,np])]).
values(lc(pp,n),[rule(np,[n]),rule(pp,[n,p])]).
values(lc(pp,ap),[rule(np,[ap,np]),rule(vp,[ap,v])]).
values(lc(pp,adv),[rule(ap,[adv]),rule(ap,[adv,adv]),rule(ap,[adv,np])]).
values(lc(pp,v),[rule(np,[v,n])]).
values(lc(s,ap),[rule(np,[ap,np]),rule(s,[ap,vp]),rule(vp,[ap,v])]).
values(lc(s,adv),[rule(ap,[adv]),rule(ap,[adv,adv]),rule(ap,[adv,np])]).
values(lc(s,v),[rule(np,[v,n])]).
values(lc(s,n),[rule(np,[n]),rule(pp,[n,p])]).
values(first(s),[adv,n,v]).
values(first(vp),[adv,n,v]).
values(first(np),[adv,n,v]).
values(first(pp),[adv,n,v]).
values(first(ap),[adv]).
values(attach(s),[attach,project]).
values(attach(vp),[attach,project]).
values(attach(np),[attach,project]).
values(attach(pp),[attach,project]).
values(attach(ap),[attach,project]).

130
packages/prism/exs/sbn.psm Normal file
View File

@ -0,0 +1,130 @@
%%%%
%%%% Bayesian networks (2) -- sbn.psm
%%%%
%%%% Copyright (C) 2004,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This example shows how to simulate Pearl's message passing
%% (without normalization) for singly connected BNs (Bayesian networks).
%%
%% Suppose that we have a Bayesian network in Fiugre 1 and that
%% we wish to compute marginal probabilites P(B) of B.
%% The distribution defined by the BN in Figure 1 is expressed
%% by a BN program in Figure 3. We transform it into another
%% program that defines the same marginal distribuion for B.
%%
%% Original graph Transformed graph
%%
%% A B B
%% / \ / |
%% / \ / v
%% C D ==> D
%% / \ / | \
%% / \ / v v
%% E F A E F
%% /
%% v
%% C
%% (Figure 1) (Figure 2)
%%
%% Original BN program for Figure 1
%%
world(VA,VB,VC,VD,VE,VF):-
msw(par('A',[]),VA), msw(par('B',[]),VB),
msw(par('C',[VA]),VC), msw(par('D',[VA,VB]),VD),
msw(par('E',[VD]),VE), msw(par('F',[VD]),VF).
check_B(VB):- world(_,VB,_,_,_,_).
%%
%% (Figure 3)
%%
%% Transformation:
%% [Step 1] Transform the orignal BN in Figure 1 into Figure 2 by letting
%% B be the top node and other nodes dangle from B.
%% [Step 2] Construct a program that calls nodes in Figure 2 from the top
%% node to leaves. For example for D, add clause
%%
%% call_BD(VB):- call_DA(VA),call_DE(VE),call_DF(VF).
%%
%% while inserting an msw expressing the CPT P(D|A,B) in the body. Here,
%%
%% call_XY(V) <=>
%% node Y is called from X with ground term V (=X's realization)
%%
%% It can be proved by unfolding that the transformed program is equivalent
%% in distribution semantics to the original program in Figure 3.
%% => Both programs compute the same marginal distribution for B.
%% Confirm by ?- prob(ask_B(2),X),prob(check_B(2),Y).
%%-------------------------------------
%% Quick start : sample session
%%
%% ?- prism(sbn),go. % Learn parameters from randomly generated
%% % 100 samples while preserving the marginal
%% % disribution P(B)
%%
%% ?- prob(ask_B(2)).
%% ?- prob(ask_B(2),X),prob(check_B(2),Y). % => X=Y
%% ?- probf(ask_B(2)).
%% ?- sample(ask_B(X)).
%%
%% ?- viterbi(ask_B(2)).
%% ?- viterbif(ask_B(2),P,E),print_graph(E).
go:- sbn_learn(100).
%%------------------------------------
%% Declarations:
values(par('A',[]), [0,1]). % Declare msw(par('A',[]),VA) where
values(par('B',[]), [2,3]). % VA is one of {0,1}
values(par('C',[_]), [4,5]).
values(par('D',[_,_]),[6,7]). % Declare msw(par('D',[VA,VB]),VD) where
values(par('E',[_]), [8,9]). % VD is one of {6,7}
values(par('F',[_]), [10,11]).
set_params:- % Call set_sw/2 built-in
set_sw(par('A',[]), [0.3,0.7]),
set_sw(par('B',[]), uniform), % => [0.5,0.5]
set_sw(par('C',[0]), f_geometric(3,asc)), % => [0.25,0.75]
set_sw(par('C',[1]), f_geometric(3,desc)), % => [0.75,0.25]
set_sw(par('D',[0,2]),f_geometric(3)), % => [0.75,0.25]
set_sw(par('D',[1,2]),f_geometric(2)), % => [0.666...,0.333...]
set_sw(par('D',[0,3]),f_geometric), % => [0.666...,0.333...]
set_sw(par('D',[1,3]),[0.3,0.7]),
set_sw(par('E',[6]), [0.3,0.7]),
set_sw(par('E',[7]), [0.1,0.9]),
set_sw(par('F',[6]), [0.3,0.7]),
set_sw(par('F',[7]), [0.1,0.9]).
:- set_params.
%%------------------------------------
%% Modeling part: transformed program defining P(B)
ask_B(VB) :- % ?- prob(ask_B(2),X)
msw(par('B',[]),VB), % => X = P(B=2)
call_BD(VB).
call_BD(VB):- % msw's Id must be ground
call_DA(VA), % => VA must be ground
msw(par('D',[VA,VB]),VD), % => call_DA(VA)
call_DE(VD), % before msw(par('D',[VA,VB]),VD)
call_DF(VD).
call_DA(VA):-
msw(par('A',[]),VA),
call_AC(VA).
call_AC(VA):-
msw(par('C',[VA]),_VC).
call_DE(VD):-
msw(par('E',[VD]),_VE).
call_DF(VD):-
msw(par('F',[VD]),_VF).
%%------------------------------------
%% Utility part:
sbn_learn(N):- % Learn parameters (CPTs) from a list of
random_set_seed(123456), % N randomly generated ask_B(.) atoms
set_params,
get_samples(N,ask_B(_),Goals),
learn(Goals).

112
packages/prism/exs/votes.psm Normal file
View File

@ -0,0 +1,112 @@
%%%%
%%%% Evaluation of a naive Bayes classifier for `votes' dataset
%%%% --- votes.psm
%%%%
%%%% Copyright (C) 2009
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% In this program, we conduct n-fold cross validation of a naive Bayes
%% classifier. This program was created to demonstrate the usefulness of
%% the built-in predicates introduced since version 1.12. The target
%% dataset is the congressional voting records (`votes') dataset, which
%% is available from UCI machine learning repository (http://archive.ics.
%% uci.edu/ml/).
%%
%% From this program, it is seen that, using new built-in predicates such
%% as maplist/5, avglist/2, random_shuffle/2, and so on, we can make the
%% utility part compact, as well as the modeling part. Also one may find
%% that we only combine general-purpose built-ins to implement n-fold cross
%% validation.
%%-------------------------------------
%% Quick start : sample session
%%
%% (Preparation: Download the data file `house-votes-84.data' from UCI ML
%% repository, and put it `as-is' on the current directly)
%%
%% ?- prism(votes),votes_learn. % Learn parameters from the whole dataset
%%
%% ?- prism(votes),votes_cv(10). % Conduct 10-fold cross validation
%%
%%-------------------------------------
%% Declarations
values(class,[democrat,republican]). % class labels
values(attr(_,_),[y,n]). % all attributes have two values: y or n
%%-------------------------------------
%% Modeling part (a naive Bayes model)
%%
%% [Note]
%% According to `house-votes-84.names', a data description file for the
%% `votes' dataset, '?' simply denotes that the value is not "yea" nor
%% "nay". On the other hand, in this program, we consider '?' as a missing
%% value just for demonstration purpose.
nbayes(C,Vals):- msw(class,C),nbayes(1,C,Vals).
nbayes(_,_,[]).
nbayes(J,C,[V|Vals]):-
choose(J,C,V),
J1 is J+1,
nbayes(J1,C,Vals).
choose(J,C,V):-
( V == '?' -> msw(attr(J,C),_) % handling '?' as a missing value
; msw(attr(J,C),V0),
V = V0
).
%%-------------------------------------
%% Utility part:
%% Batch routine for a simple learning
votes_learn:-
load_data_file(Gs),
learn(Gs).
%% Batch routine for N-fold cross validation
votes_cv(N):-
random_set_seed(81729), % Fix the random seed to keep the same splitting
load_data_file(Gs0), % Load the entire data
random_shuffle(Gs0,Gs), % Randomly reorder the data
numlist(1,N,Ks), % Get Ks = [1,...,N] (B-Prolog built-in)
maplist(K,Rate,votes_cv(Gs,K,N,Rate),Ks,Rates),
% Call votes_cv/2 for K=1...N
avglist(Rates,AvgRate), % Get the avg. of the precisions
maplist(K,Rate,format("Test #~d: ~2f%~n",[K,Rate*100]),Ks,Rates),
format("Average: ~2f%~n",[AvgRate*100]).
%% Subroutine for learning and testing for K-th split data (K = 1...N)
votes_cv(Gs,K,N,Rate):-
format("<<<< Test #~d >>>>~n",[K]),
separate_data(Gs,K,N,Gs0,Gs1), % Gs0: training data, Gs1: test data
learn(Gs0), % Learn by PRISM's built-in
maplist(nbayes(C,Vs),R,(viterbig(nbayes(C0,Vs)),(C0==C->R=1;R=0)),Gs1,Rs),
% Predict the class by viterbig/1 for each test example
% and evaluate it with the answer class label
avglist(Rs,Rate), % Get the accuracy for the K-th splitting
format("Done (~2f%).~n~n",[Rate*100]).
%% Split the entire data (Data) into the training data (Train)
%% and the test data (Test) for the K-th evaluation (K=1...N)
separate_data(Data,K,N,Train,Test):-
length(Data,L),
L0 is L*(K-1)//N, % L0: offset of the test data (// - integer division)
L1 is L*(K-0)//N-L0, % L1: size of the test data
splitlist(Train0,Rest,Data,L0), % Length of Train0 = L0
splitlist(Test,Train1,Rest,L1), % Length of Test = L1
append(Train0,Train1,Train).
%% Load the `votes' data in CSV form and convert it to suitable
%% Prolog terms
load_data_file(Gs):-
load_csv('house-votes-84.data',Gs0),
maplist(csvrow([C|Vs]),nbayes(C,Vs),true,Gs0,Gs).

16
packages/prism/src/README Normal file
View File

@ -0,0 +1,16 @@
========================== README (src) ==========================
This directory contains the source files of the PRISM part, along
with a minimal set of source and binary files from B-Prolog,
required to build the PRISM system:
c/ ... C code
prolog/ ... Prolog code
Please use/modify/distribute the source code based on the license
agreements described $(TOP)/LICENSE and $(TOP)/LICENSE.src, where
$(TOP) is the top directory in the unfolded package.
To build the PRISM system, we need to compile both C and Prolog
source files. Please follow the instructions described in READMEs
at the `c' and `prolog' directories.

91
packages/prism/src/c/Makefile.in Normal file
View File

@ -0,0 +1,91 @@
# -*- Makefile -*-
#
# default base directory for YAP installation
# (EROOT for architecture-dependent files)
#
prefix = @prefix@
exec_prefix = @exec_prefix@
ROOTDIR = $(prefix)
EROOTDIR = @exec_prefix@
abs_top_builddir = @abs_top_builddir@
#
# where the binary should be
#
BINDIR = $(EROOTDIR)/bin
#
# where YAP should look for libraries
#
LIBDIR=@libdir@
YAPLIBDIR=@libdir@/Yap
YAP_EXTRAS=@YAP_EXTRAS@ -D_YAP_NOT_INSTALLED_=1 -D__YAP_PROLOG__=1
#
#
CC=@CC@
CFLAGS= @SHLIB_CFLAGS@ $(YAP_EXTRAS) $(DEFS) -I$(srcdir) -I../../../.. -I$(srcdir)/../../../../include -I$(srcdir)/../../../../H -I$(srcdir)/../../../../library/dialect/bprolog/fli
LDFLAGS=@LDFLAGS@
#
#
# You shouldn't need to change what follows.
#
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
SHELL=/bin/sh
RANLIB=@RANLIB@
srcdir=@srcdir@
SO=@SO@
#4.1VPATH=@srcdir@:@srcdir@/OPTYap
CWD=$(PWD)
#
##----------------------------------------------------------------------
ifeq ($(PROCTYPE),mp)
SUBDIRS += $(MP_DIR)
OBJS += $(MP_OBJS)
endif
##----------------------------------------------------------------------
include $(srcdir)/makefiles/Makefile.files
S=/
O=o
SOBJS=prism.@SO@
#in some systems we just create a single object, in others we need to
# create a libray
all: $(SOBJS)
core/%.o: $(srcdir)/core/%.c
$(CC) -c $(CFLAGS) $< -o $@
up/%.o: $(srcdir)/up/%.c
$(CC) -c $(CFLAGS) $< -o $@
mp/%.o: $(srcdir)/mp/%.c
$(CC) -c $(CFLAGS) $< -o $@
@DO_SECOND_LD@prism.@SO@: $(OBJS)
@DO_SECOND_LD@ @SHLIB_LD@ $(LDFLAGS) -o $@ $(OBJS) @EXTRA_LIBS_FOR_DLLS@
all: $(TARGET)
install: $(TARGET)
$(INSTALL_PROGRAM) $(SOBJS) $(DESTDIR)$(YAPLIBDIR)
clean: clean_subdirs
$(RM) $(TARGET)
clean_subdirs:
for i in $(SUBDIRS); do \
($(MAKE) -f $(MAKEFILE) -C $$i clean ) \
done
##----------------------------------------------------------------------
.PHONY: all install clean $(SUBDIRS)
##----------------------------------------------------------------------

401
packages/prism/src/c/core/bpx.c Normal file
View File

@ -0,0 +1,401 @@
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include <assert.h>
#include "core/bpx.h"
#include "core/vector.h"
/*--------------------------------------------------------------------*/
#define REQUIRE_HEAP(n) \
( heap_top + (n) <= local_top ? \
(void)(0) : myquit(STACK_OVERFLOW, "stack + heap") )
/*--------------------------------------------------------------------*/
/* Functions from B-Prolog */
/* cpred.c */
int bp_string_2_term(const char *, TERM, TERM);
char* bp_term_2_string(TERM);
int bp_call_term(TERM);
int bp_mount_query_term(TERM);
int bp_next_solution(void);
/* file.c */
void write_term(TERM);
/* float1.c */
double floatval(TERM);
TERM encodefloat1(double);
/* loader.c */
SYM_REC_PTR insert(const char *, int, int);
/* mic.c */
NORET quit(const char *);
NORET myquit(int, const char *);
/* unify.c */
int unify(TERM, TERM);
int is_UNIFIABLE(TERM, TERM);
int is_IDENTICAL(TERM, TERM);
/* prism.c */
NORET bp4p_quit(int);
/*--------------------------------------------------------------------*/
static NORET bpx_raise(const char *fmt, ...)
{
va_list ap;
fprintf(curr_out, "*** {PRISM BPX ERROR: ");
va_start(ap, fmt);
vfprintf(curr_out, fmt, ap);
va_end(ap);
fprintf(curr_out, "}\n");
bp4p_quit(1);
}
/*--------------------------------------------------------------------*/
bool bpx_is_var(TERM t)
{
XDEREF(t);
return ISREF(t);
}
bool bpx_is_atom(TERM t)
{
XDEREF(t);
return ISATOM(t);
}
bool bpx_is_integer(TERM t)
{
XDEREF(t);
return ISINT(t);
}
bool bpx_is_float(TERM t)
{
XDEREF(t);
return ISNUM(t);
}
bool bpx_is_nil(TERM t)
{
XDEREF(t);
return ISNIL(t);
}
bool bpx_is_list(TERM t)
{
XDEREF(t);
return ISLIST(t);
}
bool bpx_is_structure(TERM t)
{
XDEREF(t);
return ISSTRUCT(t);
}
bool bpx_is_compound(TERM t)
{
XDEREF(t);
return ISCOMPOUND(t);
}
bool bpx_is_unifiable(TERM t1, TERM t2)
{
XDEREF(t1);
XDEREF(t2);
return (bool)(is_UNIFIABLE(t1, t2));
}
bool bpx_is_identical(TERM t1, TERM t2)
{
XDEREF(t1);
XDEREF(t2);
return (bool)(is_IDENTICAL(t1, t2));
}
/*--------------------------------------------------------------------*/
TERM bpx_get_call_arg(BPLONG i, BPLONG arity)
{
if (i < 1 || i > arity) {
bpx_raise("index out of range");
}
return ARG(i, arity);
}
BPLONG bpx_get_integer(TERM t)
{
XDEREF(t);
if (ISINT(t)) {
return INTVAL(t);
}
else {
bpx_raise("integer expected");
}
}
double bpx_get_float(TERM t)
{
XDEREF(t);
if (ISINT(t)) {
return (double)(INTVAL(t));
}
else if (ISFLOAT(t)) {
return floatval(t);
}
else {
bpx_raise("integer or floating number expected");
}
}
const char * bpx_get_name(TERM t)
{
XDEREF(t);
switch (XTAG(t)) {
case STR:
return GET_NAME_STR(GET_STR_SYM_REC(t));
case ATM:
return GET_NAME_ATOM(GET_ATM_SYM_REC(t));
case LST:
return ".";
default:
bpx_raise("callable expected");
}
}
int bpx_get_arity(TERM t)
{
XDEREF(t);
switch (XTAG(t)) {
case STR:
return GET_ARITY_STR(GET_STR_SYM_REC(t));
case ATM:
return GET_ARITY_ATOM(GET_ATM_SYM_REC(t));
case LST:
return 2;
default:
bpx_raise("callable expected");
}
}
TERM bpx_get_arg(BPLONG i, TERM t)
{
BPLONG n, j;
XDEREF(t);
switch (XTAG(t)) {
case STR:
n = GET_ARITY_STR(GET_STR_SYM_REC(t));
j = 0;
break;
case LST:
n = 2;
j = 1;
break;
default:
bpx_raise("compound expected");
}
if (i < 1 || i > n) {
bpx_raise("bad argument index");
}
return GET_ARG(t, i - j);
}
TERM bpx_get_car(TERM t)
{
XDEREF(t);
if (ISLIST(t)) {
return GET_CAR(t);
}
else {
bpx_raise("list expected");
}
}
TERM bpx_get_cdr(TERM t)
{
XDEREF(t);
if (ISLIST(t)) {
return GET_CDR(t);
}
else {
bpx_raise("list expected");
}
}
/*--------------------------------------------------------------------*/
TERM bpx_build_var(void)
{
TERM term;
REQUIRE_HEAP(1);
term = (TERM)(heap_top);
NEW_HEAP_FREE;
return term;
}
TERM bpx_build_integer(BPLONG n)
{
return MAKEINT(n);
}
TERM bpx_build_float(double x)
{
REQUIRE_HEAP(4);
return encodefloat1(x);
}
TERM bpx_build_atom(const char *name)
{
SYM_REC_PTR sym;
sym = insert(name, strlen(name), 0);
return ADDTAG(sym, ATM);
}
TERM bpx_build_list(void)
{
TERM term;
REQUIRE_HEAP(2);
term = ADDTAG(heap_top, LST);
NEW_HEAP_FREE;
NEW_HEAP_FREE;
return term;
}
TERM bpx_build_nil(void)
{
return nil_sym;
}
TERM bpx_build_structure(const char *name, BPLONG arity)
{
SYM_REC_PTR sym;
TERM term;
REQUIRE_HEAP(arity + 1);
term = ADDTAG(heap_top, STR);
sym = insert(name, strlen(name), arity);
NEW_HEAP_NODE((TERM)(sym));
while (--arity >= 0) {
NEW_HEAP_FREE;
}
return term;
}
/*--------------------------------------------------------------------*/
bool bpx_unify(TERM t1, TERM t2)
{
return (bool)(unify(t1, t2));
}
/*--------------------------------------------------------------------*/
TERM bpx_string_2_term(const char *s)
{
TERM term, vars;
int result;
REQUIRE_HEAP(2);
term = (TERM)(heap_top);
NEW_HEAP_FREE;
vars = (TERM)(heap_top);
NEW_HEAP_FREE;
result = bp_string_2_term(s, term, vars);
if (result != BP_TRUE) {
bpx_raise("parsing failed -- %s", s);
}
return term;
}
const char * bpx_term_2_string(TERM t)
{
XDEREF(t);
return bp_term_2_string(t);
}
/*--------------------------------------------------------------------*/
int bpx_call_term(TERM t)
{
XDEREF(t);
return bp_call_term(t);
}
int bpx_call_string(const char *s)
{
return bp_call_term(bpx_string_2_term(s));
}
int bpx_mount_query_term(TERM t)
{
XDEREF(t);
return bp_mount_query_term(t);
}
int bpx_mount_query_string(const char *s)
{
return bp_mount_query_term(bpx_string_2_term(s));
}
int bpx_next_solution(void)
{
if (curr_toam_status == TOAM_NOTSET) {
bpx_raise("no goal mounted");
}
return bp_next_solution();
}
/*--------------------------------------------------------------------*/
void bpx_write(TERM t)
{
XDEREF(t);
write_term(t);
}
/*--------------------------------------------------------------------*/
int bpx_printf(const char *fmt, ...)
{
va_list ap;
int r;
va_start(ap, fmt);
r = vfprintf(curr_out, fmt, ap);
va_end(ap);
return r;
}
/*--------------------------------------------------------------------*/
#ifdef __YAP_PROLOG__
BPLONG toam_signal_vec;
BPLONG illegal_arguments;
BPLONG failure_atom;
BPLONG number_var_exception;
#endif

323
packages/prism/src/c/core/bpx.h Normal file
View File

@ -0,0 +1,323 @@
#ifndef BPX_H
#define BPX_H
#include "bprolog.h"
#include "stuff.h"
#ifdef __YAP_PROLOG__
#include <stdio.h>
#include <stdlib.h>
#include <YapTerm.h>
#include <YapTags.h>
#include <YapRegs.h>
typedef void *SYM_REC_PTR;
#define heap_top H
#define local_top ASP
#define trail_top TR
#define trail_up_addr ((tr_fr_ptr)LCL0)
#define UNDO_TRAILING while (TR > (tr_fr_ptr)trail_top0) { RESET_VARIABLE(VarOfTerm(TrailTerm(TR--))); }
#define NEW_HEAP_NODE(x) (*heap_top++ = (x))
#define STACK_OVERFLOW 1
/*====================================================================*/
#define ARG(X,Y) XREGS[X]
#define XDEREF(T) while (IsVarTerm(T)) { CELL *next = VarOfTerm(T); if (IsUnboundVar(next)) break; (T) = *next; }
#define MAKEINT(I) bp_build_integer(I)
#define INTVAL(T) bp_get_integer(T)
#define MAX_ARITY 256
#define BP_MALLOC(X,Y,Z) ( X = malloc((Y)*sizeof(BPLONG)) )
#define NULL_TERM ((TERM)(0))
#define REF0 0x0L
#define REF1 0x1L
#define SUSP 0x2L
#define LST 0x4L
#define ATM 0x8L
#define INT 0x10L
#define STR 0x20L
#define NVAR (LST|ATM|INT|STR)
#define GET_STR_SYM_REC(p) ((SYM_REC_PTR)*RepAppl(p))
#define GET_ATM_SYM_REC(p) ((SYM_REC_PTR)AtomOfTerm(p))
#define GET_ARITY_STR(s) YAP_ArityOfFunctor((YAP_Functor)(s))
#define GET_ARITY_ATOM(s) 0
#define GET_NAME_STR(f) YAP_AtomName(YAP_NameOfFunctor((YAP_Functor)(f)))
#define GET_NAME_ATOM(a) YAP_AtomName((YAP_Atom)(a))
static inline
long int XTAG(TERM t)
{
switch(YAP_TagOfTerm(t)) {
case YAP_TAG_UNBOUND:
return REF0;
case YAP_TAG_ATT:
return SUSP;
case YAP_TAG_REF:
return REF1;
case YAP_TAG_PAIR:
return LST;
case YAP_TAG_ATOM:
return ATM;
case YAP_TAG_INT:
return INT;
case YAP_TAG_LONG_INT:
return INT;
case YAP_TAG_APPL:
default:
return STR;
}
}
extern inline TERM ADDTAG(void * t,int tag) {
if (tag == ATM)
return MkAtomTerm((Atom)t);
if (tag == LST)
return AbsPair((CELL *)t);
return AbsAppl((CELL *)t);
}
#define ISREF(t) IsVarTerm(t)
#define ISATOM(t) IsAtomTerm(t)
#define ISINT(t) IsIntegerTerm(t)
#define ISNUM(t) YAP_IsNumberTerm(t)
#define ISNIL(t) YAP_IsTermNil(t)
#define ISLIST(t) IsPairTerm(t)
#define ISSTRUCT(t) IsApplTerm(t)
#define ISFLOAT(t) IsFloatTerm(t)
#define ISCOMPOUND(t) YAP_IsCompoundTerm(t)
#define floatval FloatOfTerm
#define encodefloat1 MkFloatTerm
extern inline int is_UNIFIABLE(TERM t1, TERM t2)
{
return YAP_Unifiable(t1, t2);
}
extern inline int is_IDENTICAL(TERM t1, TERM t2)
{
return YAP_ExactlyEqual(t1, t2);
}
#define SWITCH_OP(T,NDEREF,VCODE,ACODE,LCODE,SCODE,SUCODE) \
switch (XTAG((T))) { \
case REF0: \
VCODE \
case LST: \
LCODE \
case SUSP: \
SUCODE \
case STR: \
SCODE \
default: \
ACODE \
}
#define XNDEREF(X,LAB)
#define GET_ARG(A,I) YAP_ArgOfTerm((I),(A))
#define GET_CAR(A) YAP_HeadOfTerm(A)
#define GET_CDR(A) YAP_TailOfTerm(A)
#define MAKE_NVAR(id) ( (YAP_Term)(id) )
#define float_psc ((YAP_Functor)FunctorDouble)
#define NEW_HEAP_FREE (*H = (CELL)H); H++
#define nil_sym YAP_TermNil()
extern BPLONG illegal_arguments;
extern BPLONG failure_atom;
extern BPLONG number_var_exception;
extern BPLONG toam_signal_vec;
#define unify YAP_Unify
extern inline char *
bp_term_2_string(TERM t)
{
char *buf = malloc(256);
if (!buf) return NULL;
YAP_WriteBuffer(t, buf, 256, 0);
return buf;
}
// char *bp_get_name(TERM t)
extern inline int
bp_string_2_term(const char *s, TERM to, TERM tv)
{
TERM t0 = YAP_ReadBuffer(s, NULL);
TERM t1 = YAP_TermNil(); // for now
return unify(t0, to) && unify(t1,tv);
}
extern inline SYM_REC_PTR
insert(const char *name, int size, int arity)
{
if (!arity) {
return (SYM_REC_PTR)YAP_LookupAtom(name);
}
return (SYM_REC_PTR)YAP_MkFunctor(YAP_LookupAtom(name), arity);
}
extern inline int
compare(TERM t1, TERM t2)
{
// compare terms??
return YAP_CompareTerms(t1,t2);
}
extern inline void
write_term(TERM t)
{
YAP_Write(t,NULL,0);
}
static NORET quit(const char *s)
{
fprintf(stderr,"PRISM QUIT: %s\n",s);
exit(0);
}
static NORET myquit(int i, const char *s)
{
fprintf(stderr,"PRISM QUIT: %s\n",s);
exit(i);
}
// vsc: why two arguments?
static inline int
list_length(BPLONG t1, BPLONG t2)
{
return YAP_ListLength((TERM)t1);
}
#define PRE_NUMBER_VAR(X)
static inline void
numberVarTermOpt(TERM t)
{
YAP_NumberVars(t, 0);
}
static inline TERM
unnumberVarTerm(TERM t, BPLONG_PTR pt1, BPLONG_PTR pt2)
{
return YAP_UnNumberVars(t);
}
extern inline int
unifyNumberedTerms(TERM t1, TERM t2)
{
if (YAP_Unify(t1,t2))
return TRUE;
return FALSE;
}
#define IsNumberedVar YAP_IsNumberedVariable
#else
#define GET_ARITY_ATOM GET_ARITY
#define GET_ARITY_STR GET_ARITY
#define GET_NAME_STR GET_NAME
#define GET_NAME_ATOM GET_NAME
/*====================================================================*/
#define NULL_TERM ((TERM)(0))
/*--------------------------------*/
/* These are the safer versions of DEREF and NDEREF macros. */
#define XDEREF(op) \
do { if(TAG(op) || (op) == FOLLOW(op)) { break; } (op) = FOLLOW(op); } while(1)
#define XNDEREF(op, label) \
do { if(TAG(op) || (op) == FOLLOW(op)) { break; } (op) = FOLLOW(op); goto label; } while(1)
/*--------------------------------*/
/* This low-level macro provides more detailed information about the */
/* type of a given term than TAG(op). */
#define XTAG(op) ((op) & TAG_MASK)
#define REF0 0x0L
#define REF1 TOP_BIT
#define INT INT_TAG
#define NVAR TAG_MASK
/*--------------------------------*/
/* The following macros are the same as IsNumberedVar and NumberVar */
/* respectively, provided just for more consistent naming. */
#define IS_NVAR(op) ( ((op) & TAG_MASK) == NVAR )
#define MAKE_NVAR(id) ( (((BPLONG)(id)) << 2) | NVAR )
/*--------------------------------*/
/* This macro is redefined to reduce warnings on GCC 4.x. */
#if defined LINUX && ! defined M64BITS
#undef UNTAGGED_ADDR
#define UNTAGGED_ADDR(op) ( (((BPLONG)(op)) & VAL_MASK0) | addr_top_bit )
#endif
/*====================================================================*/
#endif /* YAP */
bool bpx_is_var(TERM);
bool bpx_is_atom(TERM);
bool bpx_is_integer(TERM);
bool bpx_is_float(TERM);
bool bpx_is_nil(TERM);
bool bpx_is_list(TERM);
bool bpx_is_structure(TERM);
bool bpx_is_compound(TERM);
bool bpx_is_unifiable(TERM, TERM);
bool bpx_is_identical(TERM, TERM);
TERM bpx_get_call_arg(BPLONG, BPLONG);
BPLONG bpx_get_integer(TERM);
double bpx_get_float(TERM);
const char* bpx_get_name(TERM);
int bpx_get_arity(TERM);
TERM bpx_get_arg(BPLONG, TERM);
TERM bpx_get_car(TERM);
TERM bpx_get_cdr(TERM);
TERM bpx_build_var(void);
TERM bpx_build_integer(BPLONG);
TERM bpx_build_float(double);
TERM bpx_build_atom(const char *);
TERM bpx_build_list(void);
TERM bpx_build_nil(void);
TERM bpx_build_structure(const char *, BPLONG);
bool bpx_unify(TERM, TERM);
TERM bpx_string_2_term(const char *);
const char* bpx_term_2_string(TERM);
#endif /* BPX_H */

108
packages/prism/src/c/core/error.c Normal file
View File

@ -0,0 +1,108 @@
#include <stdarg.h>
#include "bprolog.h"
#include "core/bpx.h"
/*--------------------------------------------------------------------*/
#ifndef __YAP_PROLOG__
TERM bpx_build_atom(const char *);
#endif
/*--------------------------------------------------------------------*/
TERM err_runtime;
TERM err_internal;
TERM err_cycle_detected;
TERM err_invalid_likelihood;
TERM err_invalid_free_energy;
TERM err_invalid_numeric_value;
TERM err_invalid_goal_id;
TERM err_invalid_switch_instance_id;
TERM err_underflow;
TERM err_overflow;
TERM err_ctrl_c_pressed;
TERM ierr_invalid_likelihood;
TERM ierr_invalid_free_energy;
TERM ierr_function_not_implemented;
TERM ierr_unmatched_branches;
/*--------------------------------------------------------------------*/
TERM build_runtime_error(const char *s)
{
TERM t;
if (s == NULL) return bpx_build_atom("prism_runtime_error");
t = bpx_build_structure("prism_runtime_error",1);
bpx_unify(bpx_get_arg(1,t),bpx_build_atom(s));
return t;
}
TERM build_internal_error(const char *s)
{
TERM t;
if (s == NULL) return bpx_build_atom("prism_internal_error");
t = bpx_build_structure("prism_internal_error",1);
bpx_unify(bpx_get_arg(1,t),bpx_build_atom(s));
return t;
}
/*--------------------------------------------------------------------*/
void register_prism_errors(void)
{
err_runtime = build_runtime_error(NULL);
err_internal = build_internal_error(NULL);
err_cycle_detected = build_runtime_error("cycle_detected");
err_invalid_likelihood = build_runtime_error("invalid_likelihood");
err_invalid_free_energy = build_runtime_error("invalid_free_energy");
err_invalid_numeric_value = build_runtime_error("invalid_numeric_value");
err_invalid_goal_id = build_runtime_error("invalid_goal_id");
err_invalid_switch_instance_id = build_runtime_error("invalid_switch_instance_id");
err_underflow = build_runtime_error("underflow");
err_overflow = build_runtime_error("overflow");
err_ctrl_c_pressed = build_runtime_error("ctrl_c_pressed");
ierr_invalid_likelihood = build_internal_error("invalid_likelihood");
ierr_invalid_free_energy = build_internal_error("invalid_free_energy");
ierr_function_not_implemented = build_internal_error("function_not_implemented");
ierr_unmatched_branches = build_internal_error("unmatched_branches");
}
/*--------------------------------------------------------------------*/
void emit_error(const char *fmt, ...)
{
va_list ap;
fprintf(curr_out, "*** PRISM ERROR: ");
va_start(ap, fmt);
vfprintf(curr_out, fmt, ap);
va_end(ap);
fprintf(curr_out, "\n");
fflush(curr_out);
}
void emit_internal_error(const char *fmt, ...)
{
va_list ap;
fprintf(curr_out, "*** PRISM INTERNAL ERROR: ");
va_start(ap, fmt);
vfprintf(curr_out, fmt, ap);
va_end(ap);
fprintf(curr_out, "\n");
fflush(curr_out);
}
/*--------------------------------------------------------------------*/

66
packages/prism/src/c/core/error.h Normal file
View File

@ -0,0 +1,66 @@
#ifndef ERROR_H
#define ERROR_H
/*--------------------------------------------------------------------*/
#define RET_ERR(err) \
do { \
exception = (err); \
return BP_ERROR; \
} while (0)
#define RET_RUNTIME_ERR \
do { \
exception = err_runtime; \
return BP_ERROR; \
} while (0)
#define RET_INTERNAL_ERR \
do { \
exception = err_internal; \
return BP_ERROR; \
} while (0)
#define RET_ON_ERR(expr) \
do { \
if ((expr) == BP_ERROR) return BP_ERROR; \
} while (0)
#define RET_ERR_ON_ERR(expr,err) \
do { \
if ((expr) == BP_ERROR) { \
exception = (err); \
return BP_ERROR; \
} \
} while (0)
/*--------------------------------------------------------------------*/
extern TERM err_runtime;
extern TERM err_internal;
extern TERM err_cycle_detected;
extern TERM err_invalid_likelihood;
extern TERM err_invalid_free_energy;
extern TERM err_invalid_numeric_value;
extern TERM err_invalid_goal_id;
extern TERM err_invalid_switch_instance_id;
extern TERM err_underflow;
extern TERM err_overflow;
extern TERM err_ctrl_c_pressed;
extern TERM ierr_invalid_likelihood;
extern TERM ierr_invalid_free_energy;
extern TERM ierr_function_not_implemented;
extern TERM ierr_unmatched_branches;
/*--------------------------------------------------------------------*/
TERM build_runtime_error(const char *);
TERM build_internal_error(const char *);
void emit_error(const char *, ...);
void emit_internal_error(const char *, ...);
/*--------------------------------------------------------------------*/
#endif /* ERROR_H */

11
packages/prism/src/c/core/fputil.c Normal file
View File

@ -0,0 +1,11 @@
#include "core/fputil.h"
double fputil_snan(void)
{
return +sqrt(-1);
}
double fputil_qnan(void)
{
return -sqrt(-1);
}

51
packages/prism/src/c/core/fputil.h Normal file
View File

@ -0,0 +1,51 @@
#ifndef FPUTIL_H
#define FPUTIL_H
/*--------------------------------------------------------------------*/
#include <math.h>
#ifdef __STDC_VERSION__
#if __STDC_VERSION__ >= 199901L
#define C99
#endif
#endif
/*--------------------------------------------------------------------*/
#if defined C99
/* (empty) */
#elif defined _MSC_VER
#include <float.h>
#define isfinite _finite
#define isnan _isnan
#define INFINITY HUGE_VAL
#elif defined LINUX
# ifndef isfinite
# define isfinite finite
# endif
# ifndef isnan
# define isnan isnan
# endif
# ifndef INFINITY
# define INFINITY HUGE_VAL
# endif
#elif defined DARWIN
/* (empty) */
#else
#define isfinite(x) (0.0 * (x) != 0.0)
#define isnan(x) ((x) != (x))
#define INFINITY HUGE_VAL
#endif
#define SNAN fputil_snan()
#define QNAN fputil_qnan()
/*--------------------------------------------------------------------*/
double fputil_snan(void);
double fputil_qnan(void);
/*--------------------------------------------------------------------*/
#endif /* FPUTIL_H */

306
packages/prism/src/c/core/gamma.c Normal file
View File

@ -0,0 +1,306 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*-
This file contains a portable implementation for a couple of gamma-
family functions, originally written for the PRISM programming system
<http://sato-www.cs.titech.ac.jp/prism/>.
The code is based on SPECFUN (Fortran program collection for special
functions by W. J. Cody et al. at Argonne National Laboratory), which
is available in public domain at <http://www.netlib.org/specfun/>.
Here is the license terms for this file (just provided to explicitly
state that the code can be used for any purpose):
------------------------------------------------------------------------------
Copyright (c) 2007-2009 Yusuke Izumi
This software is provided 'as-is', without any express or implied
warranty. In no event will the authors be held liable for any damages
arising from the use of this software.
Permission is granted to anyone to use this software for any purpose,
including commercial applications, and to alter it and redistribute it
freely, subject to the following restrictions:
1. The origin of this software must not be misrepresented; you must not
claim that you wrote the original software. If you use this software
in a product, an acknowledgment in the product documentation would be
appreciated but is not required.
2. Altered source versions must be plainly marked as such, and must not be
misrepresented as being the original software.
3. This notice may not be removed or altered from any source distribution.
------------------------------------------------------------------------------
*/
#include <math.h>
#include "core/gamma.h"
#define PI (3.14159265358979323846) /* pi */
#define PI_2 (1.57079632679489661923) /* pi / 2 */
#define PI_4 (0.78539816339744830962) /* pi / 4 */
#define LN_SQRT2PI (0.91893853320467274178) /* ln(sqrt(2 * pi)) */
/**
* Computes ln(|Gamma(x)|).
*/
double lngamma(double x)
{
/* Constants for [0.5,1.5) -------------------------------------------*/
const double D1 = -5.772156649015328605195174e-01;
const double P1[] = {
+4.945235359296727046734888e+00, +2.018112620856775083915565e+02,
+2.290838373831346393026739e+03, +1.131967205903380828685045e+04,
+2.855724635671635335736389e+04, +3.848496228443793359990269e+04,
+2.637748787624195437963534e+04, +7.225813979700288197698961e+03
};
const double Q1[] = {
+6.748212550303777196073036e+01, +1.113332393857199323513008e+03,
+7.738757056935398733233834e+03, +2.763987074403340708898585e+04,
+5.499310206226157329794414e+04, +6.161122180066002127833352e+04,
+3.635127591501940507276287e+04, +8.785536302431013170870835e+03
};
/* Constants for [1.5,4.0) -------------------------------------------*/
const double D2 = +4.227843350984671393993777e-01;
const double P2[] = {
+4.974607845568932035012064e+00, +5.424138599891070494101986e+02,
+1.550693864978364947665077e+04, +1.847932904445632425417223e+05,
+1.088204769468828767498470e+06, +3.338152967987029735917223e+06,
+5.106661678927352456275255e+06, +3.074109054850539556250927e+06
};
const double Q2[] = {
+1.830328399370592604055942e+02, +7.765049321445005871323047e+03,
+1.331903827966074194402448e+05, +1.136705821321969608938755e+06,
+5.267964117437946917577538e+06, +1.346701454311101692290052e+07,
+1.782736530353274213975932e+07, +9.533095591844353613395747e+06
};
/* Constants for [4.0,12.0) ------------------------------------------*/
const double D4 = +1.791759469228055000094023e+00;
const double P4[] = {
+1.474502166059939948905062e+04, +2.426813369486704502836312e+06,
+1.214755574045093227939592e+08, +2.663432449630976949898078e+09,
+2.940378956634553899906876e+10, +1.702665737765398868392998e+11,
+4.926125793377430887588120e+11, +5.606251856223951465078242e+11
};
const double Q4[] = {
+2.690530175870899333379843e+03, +6.393885654300092398984238e+05,
+4.135599930241388052042842e+07, +1.120872109616147941376570e+09,
+1.488613728678813811542398e+10, +1.016803586272438228077304e+11,
+3.417476345507377132798597e+11, +4.463158187419713286462081e+11
};
/* Constants for [12.0,Infinity) -------------------------------------*/
const double C[] = {
-2.955065359477124231624146e-02, +6.410256410256410034009811e-03,
-1.917526917526917633674555e-03, +8.417508417508417139715760e-04,
-5.952380952380952917890600e-04, +7.936507936507936501052685e-04,
-2.777777777777777883788657e-03, +8.333333333333332870740406e-02
};
/*--------------------------------------------------------------------*/
const double EPS = 2.22e-16;
const double P68 = 87.0 / 128.0;
const double BIG = 2.25e+76;
/*--------------------------------------------------------------------*/
double p, q, y;
int i, n;
if (x != x) /* NaN */
return x;
else if (0 * x != 0) /* Infinity */
return HUGE_VAL;
else if (x <= 0.0) {
q = modf(-2.0 * x, &p);
n = (int)(p);
q = sin(PI_2 * (n % 2 == 0 ? q : 1.0 - q));
return log(PI / q) - lngamma(1.0 - x);
}
else if (x < EPS)
return -log(x);
else if (x < 0.5) {
p = 0.0;
q = 1.0;
y = x;
for (i = 0; i < 8; i++) {
p = p * y + P1[i];
q = q * y + Q1[i];
}
return x * (D1 + y * (p / q)) - log(x);
}
else if (x < P68) {
p = 0.0;
q = 1.0;
y = x - 1.0;
for (i = 0; i < 8; i++) {
p = p * y + P2[i];
q = q * y + Q2[i];
}
return y * (D2 + y * (p / q)) - log(x);
}
else if (x < 1.5) {
p = 0.0;
q = 1.0;
y = x - 1.0;
for (i = 0; i < 8; i++) {
p = p * y + P1[i];
q = q * y + Q1[i];
}
return y * (D1 + y * (p / q));
}
else if (x < 4.0) {
p = 0.0;
q = 1.0;
y = x - 2.0;
for (i = 0; i < 8; i++) {
p = p * y + P2[i];
q = q * y + Q2[i];
}
return y * (D2 + y * (p / q));
}
else if (x < 12.0) {
p = 0.0;
q = -1.0;
y = x - 4.0;
for (i = 0; i < 8; i++) {
p = p * y + P4[i];
q = q * y + Q4[i];
}
return D4 + y * (p / q);
}
else if (x < BIG) {
p = 0.0;
q = log(x);
y = 1.0 / (x * x);
for (i = 0; i < 8; i++) {
p = p * y + C[i];
}
return p / x + LN_SQRT2PI - 0.5 * q + x * (q - 1.0);
}
else {
q = log(x);
return LN_SQRT2PI - 0.5 * q + x * (q - 1.0);
}
/*--------------------------------------------------------------------*/
}
/**
* Computes Psi(x) = (d/dx)(ln(Gamma(x)))
*/
double digamma(double x)
{
/* Constants for [0.5,3.0] -------------------------------------------*/
const double P1[] = {
+4.5104681245762934160e-03, +5.4932855833000385356e+00,
+3.7646693175929276856e+02, +7.9525490849151998065e+03,
+7.1451595818951933210e+04, +3.0655976301987365674e+05,
+6.3606997788964458797e+05, +5.8041312783537569993e+05,
+1.6585695029761022321e+05
};
const double Q1[] = {
+9.6141654774222358525e+01, +2.6287715790581193330e+03,
+2.9862497022250277920e+04, +1.6206566091533671639e+05,
+4.3487880712768329037e+05, +5.4256384537269993733e+05,
+2.4242185002017985252e+05, +6.4155223783576225996e-08
};
/* Constants for (3.0,Infinity) --------------------------------------*/
const double P2[] = {
-2.7103228277757834192e+00, -1.5166271776896121383e+01,
-1.9784554148719218667e+01, -8.8100958828312219821e+00,
-1.4479614616899842986e+00, -7.3689600332394549911e-02,
-6.5135387732718171306e-21
};
const double Q2[] = {
+4.4992760373789365846e+01, +2.0240955312679931159e+02,
+2.4736979003315290057e+02, +1.0742543875702278326e+02,
+1.7463965060678569906e+01, +8.8427520398873480342e-01
};
/*--------------------------------------------------------------------*/
const double MIN = 2.23e-308;
const double MAX = 4.50e+015;
const double SMALL = 5.80e-009;
const double LARGE = 2.71e+014;
const double X01 = 187.0 / 128.0;
const double X02 = 6.9464496836234126266e-04;
/*--------------------------------------------------------------------*/
double p, q, y, sgn;
int i, n;
sgn = (x > 0.0) ? +1.0 : -1.0;
y = fabs(x);
if (x != x) /* NaN */
return x;
else if (x < -MAX || y < MIN)
return -1.0 * sgn * HUGE_VAL;
else if (y < SMALL)
return digamma(1.0 - x) - 1.0 / x;
else if (x < 0.5) {
q = modf(4.0 * y, &p);
n = (int)(p);
switch (n % 4) {
case 0:
return digamma(1.0 - x) - sgn * PI / tan(PI_4 * q);
case 1:
return digamma(1.0 - x) - sgn * PI * tan(PI_4 * (1.0 - q));
case 2:
return digamma(1.0 - x) + sgn * PI * tan(PI_4 * q);
case 3:
return digamma(1.0 - x) + sgn * PI / tan(PI_4 * (1.0 - q));
}
}
else if (x <= 3.0) {
p = 0.0;
q = 1.0;
for (i = 0; i < 8; i++) {
p = p * x + P1[i];
q = q * x + Q1[i];
}
p = p * x + P1[8];
return p / q * ((x - X01) - X02);
}
else if (x < LARGE) {
p = 0.0;
q = 1.0;
y = 1.0 / (x * x);
for (i = 0; i < 6; i++) {
p = p * y + P2[i];
q = q * y + Q2[i];
}
p = p * y + P2[6];
return p / q - 0.5 / x + log(x);
}
return log(x);
}

7
packages/prism/src/c/core/gamma.h Normal file
View File

@ -0,0 +1,7 @@
#ifndef GAMMA_H
#define GAMMA_H
double lngamma(double);
double digamma(double);
#endif /* GAMMA_H */

197
packages/prism/src/c/core/glue.c Normal file
View File

@ -0,0 +1,197 @@
#include <stdlib.h>
/*--------------------------------------------------------------------*/
#define REGISTER_CPRED(p,n) \
do { extern int pc_ ## p ## _ ## n (void); insert_cpred("$pc_" #p, n, pc_ ## p ## _ ## n); } while (0)
/*--------------------------------------------------------------------*/
typedef struct sym_rec * SYM_REC_PTR;
typedef long int TERM;
SYM_REC_PTR insert_cpred(const char *, int, int(*)(void));
void exit(int);
#ifdef __YAP_PROLOG__
int YAP_UserCpredicate(const char *s, int (*f)(void), unsigned long int n);
SYM_REC_PTR insert_cpred(const char *s, int n, int(*f)(void))
{
YAP_UserCPredicate(s, f, n);
return NULL;
}
#endif
/*--------------------------------------------------------------------*/
void register_prism_errors(void);
#ifdef MPI
void mp_init(int *argc, char **argv[]);
void mp_done(void);
void mp_quit(int);
#endif
/*--------------------------------------------------------------------*/
void bp4p_init(int *argc, char **argv[])
{
#ifdef MPI
mp_init(argc, argv);
#endif
}
void bp4p_exit(int status)
{
#ifdef MPI
mp_done();
#endif
exit(status);
}
void bp4p_quit(int status)
{
#ifdef MPI
mp_quit(status);
#else
exit(status);
#endif
}
void bp4p_register_preds(void)
{
/* core/idtable.c */
REGISTER_CPRED(prism_id_table_init,0);
REGISTER_CPRED(prism_goal_id_register,2);
REGISTER_CPRED(prism_sw_id_register,2);
REGISTER_CPRED(prism_sw_ins_id_register,2);
REGISTER_CPRED(prism_goal_id_get,2);
REGISTER_CPRED(prism_sw_id_get,2);
REGISTER_CPRED(prism_sw_ins_id_get,2);
REGISTER_CPRED(prism_goal_count,1);
REGISTER_CPRED(prism_sw_count,1);
REGISTER_CPRED(prism_sw_ins_count,1);
REGISTER_CPRED(prism_goal_term,2);
REGISTER_CPRED(prism_sw_term,2);
REGISTER_CPRED(prism_sw_ins_term,2);
/* core/random.c */
REGISTER_CPRED(random_auto_seed, 1);
REGISTER_CPRED(random_init_by_seed, 1);
REGISTER_CPRED(random_init_by_list, 1);
REGISTER_CPRED(random_float, 1);
REGISTER_CPRED(random_gaussian, 1);
REGISTER_CPRED(random_int, 2);
REGISTER_CPRED(random_int, 3);
REGISTER_CPRED(random_get_state, 1);
REGISTER_CPRED(random_set_state, 1);
/* core/util.c */
REGISTER_CPRED(lngamma, 2);
/* up/em_preds.c */
REGISTER_CPRED(prism_prepare,4);
REGISTER_CPRED(prism_em,6);
REGISTER_CPRED(prism_vbem,2);
REGISTER_CPRED(prism_both_em,2);
REGISTER_CPRED(compute_inside,2);
REGISTER_CPRED(compute_probf,1);
/* up/viterbi.c */
REGISTER_CPRED(compute_viterbi,5);
REGISTER_CPRED(compute_n_viterbi,3);
REGISTER_CPRED(compute_n_viterbi_rerank,4);
/* up/hindsight.c */
REGISTER_CPRED(compute_hindsight,4);
/* up/graph.c */
REGISTER_CPRED(alloc_egraph,0);
REGISTER_CPRED(clean_base_egraph,0);
REGISTER_CPRED(clean_egraph,0);
REGISTER_CPRED(export_switch,2);
REGISTER_CPRED(add_egraph_path,3);
REGISTER_CPRED(alloc_sort_egraph,1);
REGISTER_CPRED(clean_external_tables,0);
REGISTER_CPRED(export_sw_info,1);
REGISTER_CPRED(import_sorted_graph_size,1);
REGISTER_CPRED(import_sorted_graph_gid,2);
REGISTER_CPRED(import_sorted_graph_paths,2);
REGISTER_CPRED(get_gnode_inside,2);
REGISTER_CPRED(get_gnode_outside,2);
REGISTER_CPRED(get_gnode_viterbi,2);
REGISTER_CPRED(get_snode_inside,2);
REGISTER_CPRED(get_snode_expectation,2);
REGISTER_CPRED(import_occ_switches,3);
REGISTER_CPRED(import_graph_stats,4);
/* up/flags.c */
REGISTER_CPRED(set_daem,1);
REGISTER_CPRED(set_em_message,1);
REGISTER_CPRED(set_em_progress,1);
REGISTER_CPRED(set_error_on_cycle,1);
REGISTER_CPRED(set_explicit_empty_expls,1);
REGISTER_CPRED(set_fix_init_order,1);
REGISTER_CPRED(set_init_method,1);
REGISTER_CPRED(set_itemp_init,1);
REGISTER_CPRED(set_itemp_rate,1);
REGISTER_CPRED(set_log_scale,1);
REGISTER_CPRED(set_max_iterate,1);
REGISTER_CPRED(set_num_restart,1);
REGISTER_CPRED(set_prism_epsilon,1);
REGISTER_CPRED(set_show_itemp,1);
REGISTER_CPRED(set_std_ratio,1);
REGISTER_CPRED(set_verb_em,1);
REGISTER_CPRED(set_verb_graph,1);
REGISTER_CPRED(set_warn,1);
REGISTER_CPRED(set_debug_level,1);
/* up/util.c */
REGISTER_CPRED(mp_mode,0);
REGISTER_CPRED(get_term_depth,2);
REGISTER_CPRED(mtrace,0);
REGISTER_CPRED(muntrace,0);
REGISTER_CPRED(sleep,1);
#ifdef MPI
/* mp/mp_preds.c */
REGISTER_CPRED(mp_size,1);
REGISTER_CPRED(mp_rank,1);
REGISTER_CPRED(mp_master,0);
REGISTER_CPRED(mp_abort,0);
REGISTER_CPRED(mp_wtime,1);
REGISTER_CPRED(mp_sync,2);
REGISTER_CPRED(mp_send_goal,1);
REGISTER_CPRED(mp_recv_goal,1);
REGISTER_CPRED(mpm_bcast_command,1);
REGISTER_CPRED(mps_bcast_command,1);
REGISTER_CPRED(mps_revert_stdout,0);
/* mp/mp_em_preds.c */
REGISTER_CPRED(mpm_prism_em,6);
REGISTER_CPRED(mps_prism_em,0);
REGISTER_CPRED(mpm_prism_vbem,2);
REGISTER_CPRED(mps_prism_vbem,0);
REGISTER_CPRED(mpm_prism_both_em,2);
REGISTER_CPRED(mps_prism_both_em,0);
REGISTER_CPRED(mpm_import_graph_stats,4);
REGISTER_CPRED(mps_import_graph_stats,0);
/* mp/mp_sw.c */
REGISTER_CPRED(mp_send_switches,0);
REGISTER_CPRED(mp_recv_switches,0);
REGISTER_CPRED(mp_send_swlayout,0);
REGISTER_CPRED(mp_recv_swlayout,0);
REGISTER_CPRED(mpm_alloc_occ_switches,0);
/* mp/mp_flags.c */
REGISTER_CPRED(mpm_share_prism_flags,0);
REGISTER_CPRED(mps_share_prism_flags,0);
#endif
/* up/error.c; FIXME: There would be a better place to call */
register_prism_errors();
}
/*--------------------------------------------------------------------*/

9
packages/prism/src/c/core/glue.h Normal file
View File

@ -0,0 +1,9 @@
#ifndef GLUE_H
#define GLUE_H
void bp4p_init(void);
void bp4p_exit(int);
void bp4p_quit(int);
void bp4p_register_preds(void);
#endif /* GLUE_H */

175
packages/prism/src/c/core/idtable.c Normal file
View File

@ -0,0 +1,175 @@
#include "core/xmalloc.h"
#include "core/vector.h"
#include "core/termpool.h"
#include "core/idtable.h"
#include "core/stuff.h"
/*--------------------------------------------------------------------*/
/* table.c */
TERM unnumberVarTerm(TERM, BPLONG_PTR, BPLONG_PTR);
/*--------------------------------------------------------------------*/
struct id_table {
TERM_POOL *store;
struct id_table_entry *elems;
IDNUM *bucks;
IDNUM nbucks;
};
struct id_table_entry {
TERM term;
IDNUM next;
};
/*--------------------------------------------------------------------*/
static void id_table_rehash(ID_TABLE *this)
{
IDNUM *bucks, nbucks, i, j;
nbucks = 2 * this->nbucks + 1;
/* find the next prime number */
for (i = 3; i * i <= nbucks; ) {
if (nbucks % i == 0) {
nbucks += 2;
i = 3;
}
else {
i += 2;
}
}
bucks = MALLOC(sizeof(struct hash_entry *) * nbucks);
for (i = 0; i < nbucks; i++)
bucks[i] = ID_NONE;
for (i = 0; i < VECTOR_SIZE(this->elems); i++) {
j = (IDNUM)((BPULONG)(this->elems[i].term) % nbucks);
this->elems[i].next = bucks[j];
bucks[j] = i;
}
FREE(this->bucks);
this->nbucks = nbucks;
this->bucks = bucks;
}
static IDNUM id_table_search(const ID_TABLE *this, TERM term)
{
BPULONG hash;
IDNUM i;
hash = (BPULONG)(term);
i = this->bucks[hash % this->nbucks];
while (i != ID_NONE) {
if (term == this->elems[i].term) {
return i;
}
i = this->elems[i].next;
}
return ID_NONE;
}
static IDNUM id_table_insert(ID_TABLE *this, TERM term)
{
BPULONG hash;
IDNUM n;
const char *bpx_term_2_string(TERM);
hash = (BPULONG)(term);
n = (IDNUM)(VECTOR_SIZE(this->elems));
if (n >= this->nbucks) {
id_table_rehash(this);
}
VECTOR_PUSH_NONE(this->elems);
this->elems[n].term = term;
this->elems[n].next = this->bucks[hash % this->nbucks];
this->bucks[hash % this->nbucks] = n;
/* fprintf(curr_out,">> TERM: %s = %d\n",bpx_term_2_string(term),n); */
return n;
}
/*--------------------------------------------------------------------*/
ID_TABLE * id_table_create(void)
{
ID_TABLE *this;
IDNUM i;
this = MALLOC(sizeof(struct id_table));
this->elems = NULL;
this->nbucks = 17; /* prime number */
this->bucks = MALLOC(sizeof(IDNUM) * this->nbucks);
this->store = term_pool_create();
for (i = 0; i < this->nbucks; i++)
this->bucks[i] = ID_NONE;
VECTOR_INIT(this->elems);
return this;
}
void id_table_delete(ID_TABLE *this)
{
VECTOR_FREE(this->elems);
FREE(this->bucks);
term_pool_delete(this->store);
FREE(this);
}
/*--------------------------------------------------------------------*/
TERM id_table_id2term(const ID_TABLE *this, IDNUM i)
{
return this->elems[i].term; /* numbered */
}
IDNUM id_table_retrieve(const ID_TABLE *this, TERM term)
{
term = term_pool_retrieve(this->store, term);
return id_table_search(this, term);
}
IDNUM id_table_register(ID_TABLE *this, TERM term)
{
BPULONG hash;
IDNUM i;
term = term_pool_register(this->store, term);
hash = (BPULONG)(term);
i = id_table_search(this, term);
if (i == ID_NONE) {
i = id_table_insert(this, term);
}
return i;
}
int id_table_count(const ID_TABLE *this)
{
return (int)VECTOR_SIZE(this->elems);
}
/*--------------------------------------------------------------------*/
TERM unnumber_var_term(TERM term)
{
BPLONG mvn = -1;
return unnumberVarTerm(term, local_top, &mvn);
}

29
packages/prism/src/c/core/idtable.h Normal file
View File

@ -0,0 +1,29 @@
#ifndef IDTABLE_H
#define IDTABLE_H
#include "bpx.h"
/*--------------------------------------------------------------------*/
#define ID_NONE ((IDNUM)(-1))
/*--------------------------------------------------------------------*/
typedef struct id_table ID_TABLE;
typedef unsigned int IDNUM;
/*--------------------------------------------------------------------*/
ID_TABLE * id_table_create(void);
void id_table_delete(ID_TABLE *);
TERM id_table_id2term(const ID_TABLE *, IDNUM);
IDNUM id_table_retrieve(const ID_TABLE *, TERM);
IDNUM id_table_register(ID_TABLE *, TERM);
int id_table_count(const ID_TABLE *);
TERM unnumber_var_term(TERM);
/*--------------------------------------------------------------------*/
#endif /* IDTABLE_H */

249
packages/prism/src/c/core/idtable_preds.c Normal file
View File

@ -0,0 +1,249 @@
#include <string.h>
#include "core/idtable.h"
/*--------------------------------------------------------------------*/
static ID_TABLE *g_table = NULL; /* goals */
static ID_TABLE *s_table = NULL; /* switches */
static ID_TABLE *i_table = NULL; /* switch instances */
/*--------------------------------------------------------------------*/
/* cpreds.c */
char * bp_term_2_string(TERM);
/* unify.c */
int unify(TERM, TERM);
/*--------------------------------------------------------------------*/
int prism_goal_id_register(TERM term)
{
return id_table_register(g_table, term);
}
int prism_sw_id_register(TERM term)
{
return id_table_register(s_table, term);
}
int prism_sw_ins_id_register(TERM term)
{
return id_table_register(i_table, term);
}
int prism_goal_id_get(TERM term)
{
return id_table_retrieve(g_table, term);
}
int prism_sw_id_get(TERM term)
{
return id_table_retrieve(s_table, term);
}
int prism_sw_ins_id_get(TERM term)
{
return id_table_retrieve(i_table, term);
}
int prism_goal_count(void)
{
return id_table_count(g_table);
}
int prism_sw_count(void)
{
return id_table_count(s_table);
}
int prism_sw_ins_count(void)
{
return id_table_count(i_table);
}
TERM prism_goal_term(IDNUM i)
{
return id_table_id2term(g_table, i);
}
TERM prism_sw_term(IDNUM i)
{
return id_table_id2term(s_table, i);
}
TERM prism_sw_ins_term(IDNUM i)
{
return id_table_id2term(i_table, i);
}
char * prism_goal_string(IDNUM i)
{
return bp_term_2_string(prism_goal_term(i));
}
char * prism_sw_string(IDNUM i)
{
return bp_term_2_string(prism_sw_term(i));
}
char * prism_sw_ins_string(IDNUM i)
{
return bp_term_2_string(prism_sw_ins_term(i));
}
/* Note: the strings returned by strdup() should be released by the caller. */
char * copy_prism_goal_string(IDNUM i)
{
return strdup(prism_goal_string(i));
}
char * copy_prism_sw_string(IDNUM i)
{
return strdup(prism_sw_string(i));
}
char * copy_prism_sw_ins_string(IDNUM i)
{
return strdup(prism_sw_ins_string(i));
}
/*--------------------------------------------------------------------*/
int pc_prism_id_table_init_0(void)
{
if (g_table != NULL) id_table_delete(g_table);
if (s_table != NULL) id_table_delete(s_table);
if (i_table != NULL) id_table_delete(i_table);
g_table = id_table_create();
s_table = id_table_create();
i_table = id_table_create();
return BP_TRUE;
}
int pc_prism_goal_id_register_2(void)
{
TERM term;
IDNUM id;
term = ARG(1,2);
XDEREF(term);
id = prism_goal_id_register(term);
return unify(MAKEINT(id), ARG(2,2));
}
int pc_prism_sw_id_register_2(void)
{
TERM term;
IDNUM id;
term = ARG(1,2);
XDEREF(term);
id = prism_sw_id_register(term);
return unify(MAKEINT(id), ARG(2,2));
}
int pc_prism_sw_ins_id_register_2(void)
{
TERM term;
IDNUM id;
term = ARG(1,2);
XDEREF(term);
id = prism_sw_ins_id_register(term);
return unify(MAKEINT(id), ARG(2,2));
}
int pc_prism_goal_id_get_2(void)
{
TERM term;
IDNUM id;
term = ARG(1,2);
XDEREF(term);
id = prism_goal_id_get(term);
if (id == ID_NONE) return BP_FALSE;
return unify(MAKEINT(id), ARG(2,2));
}
int pc_prism_sw_id_get_2(void)
{
TERM term;
IDNUM id;
term = ARG(1,2);
XDEREF(term);
id = prism_sw_id_get(term);
if (id == ID_NONE) return BP_FALSE;
return unify(MAKEINT(id), ARG(2,2));
}
int pc_prism_sw_ins_id_get_2(void)
{
TERM term;
IDNUM id;
term = ARG(1,2);
XDEREF(term);
id = prism_sw_ins_id_get(term);
if (id == ID_NONE) return BP_FALSE;
return unify(MAKEINT(id), ARG(2,2));
}
int pc_prism_goal_count_1(void)
{
return unify(MAKEINT(prism_goal_count()), ARG(1,1));
}
int pc_prism_sw_count_1(void)
{
return unify(MAKEINT(prism_sw_count()), ARG(1,1));
}
int pc_prism_sw_ins_count_1(void)
{
return unify(MAKEINT(prism_sw_ins_count()), ARG(1,1));
}
int pc_prism_goal_term_2(void)
{
TERM id, term;
id = ARG(1,2);
XDEREF(id);
term = unnumber_var_term(prism_goal_term((IDNUM)INTVAL(id)));
return unify(term, ARG(2,2));
}
int pc_prism_sw_term_2(void)
{
TERM id, term;
id = ARG(1,2);
XDEREF(id);
term = unnumber_var_term(prism_sw_term((IDNUM)INTVAL(id)));
return unify(term, ARG(2,2));
}
int pc_prism_sw_ins_term_2(void)
{
TERM id, term;
id = ARG(1,2);
XDEREF(id);
term = unnumber_var_term(prism_sw_ins_term((IDNUM)INTVAL(id)));
return unify(term, ARG(2,2));
}

41
packages/prism/src/c/core/idtable_preds.h Normal file
View File

@ -0,0 +1,41 @@
#ifndef IDTABLE_AUX_H
#define IDTABLE_AUX_H
/*--------------------------------------------------------------------*/
int prism_goal_id_register(TERM);
int prism_sw_id_register(TERM);
int prism_sw_ins_id_register(TERM);
int prism_goal_id_get(TERM);
int prism_sw_id_get(TERM);
int prism_sw_ins_id_get(TERM);
int prism_goal_count(void);
int prism_sw_id_count(void);
int prism_sw_ins_id_count(void);
TERM prism_goal_term(IDNUM);
TERM prism_sw_term(IDNUM);
TERM prism_sw_ins_term(IDNUM);
char * prism_goal_string(IDNUM);
char * prism_sw_string(IDNUM);
char * prism_sw_ins_string(IDNUM);
char * copy_prism_goal_string(IDNUM);
char * copy_prism_sw_string(IDNUM);
char * copy_prism_sw_ins_string(IDNUM);
int pc_prism_id_table_init(void);
int pc_prism_goal_id_register(void);
int pc_prism_sw_id_register(void);
int pc_prism_sw_ins_id_register(void);
int pc_prism_goal_id_get(void);
int pc_prism_sw_id_get(void);
int pc_prism_sw_ins_id_get(void);
int pc_prism_goal_count(void);
int pc_prism_sw_count(void);
int pc_prism_sw_ins_count(void);
int pc_prism_goal_term(void);
int pc_prism_sw_term(void);
int pc_prism_sw_ins_term(void);
/*--------------------------------------------------------------------*/
#endif /* IDTABLE_AUX_H */

360
packages/prism/src/c/core/random.c Normal file
View File

@ -0,0 +1,360 @@
/*
This source module contains reduced (and slightly modified) version
of mt19937ar.c implemented by Makoto Matsumoto and Takuji Nishimura.
The original file is available in the following website:
http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html
Here is the original copyright notice.
========================================================================
Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura,
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. The names of its contributors may not be used to endorse or promote
products derived from this software without specific prior written
permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
========================================================================
*/
/***********[ REDUCED VERSION OF MT19937AR.C STARTS HERE ]***********/
/* Period parameters */
#define N 624
#define M 397
#define MATRIX_A 0x9908b0dfUL /* constant vector a */
#define UPPER_MASK 0x80000000UL /* most significant w-r bits */
#define LOWER_MASK 0x7fffffffUL /* least significant r bits */
static unsigned long mt[N]; /* the array for the state vector */
static int mti=N+1; /* mti==N+1 means mt[N] is not initialized */
/* initializes mt[N] with a seed */
static void init_genrand(unsigned long s)
{
mt[0]= s & 0xffffffffUL;
for (mti=1; mti<N; mti++) {
mt[mti] =
(1812433253UL * (mt[mti-1] ^ (mt[mti-1] >> 30)) + mti);
/* See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. */
/* In the previous versions, MSBs of the seed affect */
/* only MSBs of the array mt[]. */
/* 2002/01/09 modified by Makoto Matsumoto */
mt[mti] &= 0xffffffffUL;
/* for >32 bit machines */
}
}
/* initialize by an array with array-length */
/* init_key is the array for initializing keys */
/* key_length is its length */
/* slight change for C++, 2004/2/26 */
void init_by_array(unsigned long init_key[], int key_length)
{
int i, j, k;
init_genrand(19650218UL);
i=1;
j=0;
k = (N>key_length ? N : key_length);
for (; k; k--) {
mt[i] = (mt[i] ^ ((mt[i-1] ^ (mt[i-1] >> 30)) * 1664525UL))
+ init_key[j] + j; /* non linear */
mt[i] &= 0xffffffffUL; /* for WORDSIZE > 32 machines */
i++;
j++;
if (i>=N) {
mt[0] = mt[N-1];
i=1;
}
if (j>=key_length) j=0;
}
for (k=N-1; k; k--) {
mt[i] = (mt[i] ^ ((mt[i-1] ^ (mt[i-1] >> 30)) * 1566083941UL))
- i; /* non linear */
mt[i] &= 0xffffffffUL; /* for WORDSIZE > 32 machines */
i++;
if (i>=N) {
mt[0] = mt[N-1];
i=1;
}
}
mt[0] = 0x80000000UL; /* MSB is 1; assuring non-zero initial array */
}
/* generates a random number on [0,0xffffffff]-interval */
static unsigned long genrand_int32(void)
{
unsigned long y;
static unsigned long mag01[2]={0x0UL, MATRIX_A};
/* mag01[x] = x * MATRIX_A for x=0,1 */
if (mti >= N) { /* generate N words at one time */
int kk;
if (mti == N+1) /* if init_genrand() has not been called, */
init_genrand(5489UL); /* a default initial seed is used */
for (kk=0;kk<N-M;kk++) {
y = (mt[kk]&UPPER_MASK)|(mt[kk+1]&LOWER_MASK);
mt[kk] = mt[kk+M] ^ (y >> 1) ^ mag01[y & 0x1UL];
}
for (;kk<N-1;kk++) {
y = (mt[kk]&UPPER_MASK)|(mt[kk+1]&LOWER_MASK);
mt[kk] = mt[kk+(M-N)] ^ (y >> 1) ^ mag01[y & 0x1UL];
}
y = (mt[N-1]&UPPER_MASK)|(mt[0]&LOWER_MASK);
mt[N-1] = mt[M-1] ^ (y >> 1) ^ mag01[y & 0x1UL];
mti = 0;
}
y = mt[mti++];
/* Tempering */
y ^= (y >> 11);
y ^= (y << 7) & 0x9d2c5680UL;
y ^= (y << 15) & 0xefc60000UL;
y ^= (y >> 18);
return y;
}
/* generates a random number on [0,1) with 53-bit resolution */
static double genrand_res53(void)
{
unsigned long a=genrand_int32()>>5, b=genrand_int32()>>6;
return(a*67108864.0+b)*(1.0/9007199254740992.0);
}
/* These real versions are due to Isaku Wada, 2002/01/09 added */
/***********[ REDUCED VERSION OF MT19937AR.C ENDS HERE ]***********/
/*--------------------------------------------------------------------*/
#include <math.h>
#include <time.h>
#include <string.h>
#include <assert.h>
#include "core/bpx.h"
#include "core/random.h"
#include "core/vector.h"
#ifndef M_PI
#define M_PI (3.14159265358979324)
#endif
static int gauss_flag = 0;
/*--------------------------------------------------------------------*/
int random_int(int n)
{
unsigned long p, q, r;
assert(n > 0);
if (n == 1) {
return 0;
}
p = 0xFFFFFFFFul - (0xFFFFFFFFul % n + 1) % n;
q = p / n + 1;
while ((r = genrand_int32()) > p) ;
return (int)(r / q);
}
double random_float(void)
{
return genrand_res53();
}
/* Box-Muller method */
double random_gaussian(double mu, double sigma)
{
double u1, u2;
static double g1, g2;
gauss_flag = !(gauss_flag);
if (gauss_flag) {
u1 = genrand_res53();
u2 = genrand_res53();
g1 = sqrt(-2.0 * log(u1)) * cos(2.0 * M_PI * u2);
g2 = sqrt(-2.0 * log(u1)) * sin(2.0 * M_PI * u2);
return sigma * g1 + mu;
}
else {
return sigma * g2 + mu;
}
}
/* N(0,1)-version:
double random_gaussian(void)
{
double u1, u2;
static double next;
gauss_flag = !(gauss_flag);
if (gauss_flag) {
do {
u1 = genrand_res53();
}
while (u1 == 0.0);
do {
u2 = genrand_res53();
}
while (u2 == 0.0);
next = sqrt(-2.0 * log(u1)) * sin(2.0 * M_PI * u2);
return sqrt(-2.0 * log(u1)) * cos(2.0 * M_PI * u2);
}
else {
return next;
}
}
*/
/*--------------------------------------------------------------------*/
int pc_random_auto_seed_1(void)
{
BPLONG seed = (BPLONG)(time(NULL));
return bpx_unify(ARG(1,1), bpx_build_integer(seed));
}
int pc_random_init_by_seed_1(void)
{
init_genrand((unsigned long)(bpx_get_integer(ARG(1,1))));
return BP_TRUE;
}
int pc_random_init_by_list_1(void)
{
unsigned long *seed;
TERM t, u;
VECTOR_INIT(seed);
t = ARG(1,1);
while (! bpx_is_nil(t)) {
u = bpx_get_car(t);
t = bpx_get_cdr(t);
VECTOR_PUSH(seed, (unsigned long)(bpx_get_integer(u)));
}
init_by_array(seed, VECTOR_SIZE(seed));
return BP_TRUE;
}
int pc_random_float_1(void)
{
return bpx_unify(ARG(1,1), bpx_build_float(random_float()));
}
int pc_random_gaussian_1(void)
{
return bpx_unify(ARG(1,1), bpx_build_float(random_gaussian(0.0,1.0)));
}
int pc_random_int_2(void)
{
int n_max = bpx_get_integer(ARG(1,2));
int n_out = random_int(n_max);
return bpx_unify(ARG(2,2), bpx_build_integer((BPLONG)(n_out)));
}
int pc_random_int_3(void)
{
int n_min = bpx_get_integer(ARG(1,3));
int n_max = bpx_get_integer(ARG(2,3));
int n_out = random_int(n_max - n_min + 1) + n_min;
return bpx_unify(ARG(3,3), bpx_build_integer((BPLONG)(n_out)));
}
/*--------------------------------------------------------------------*/
int pc_random_get_state_1(void)
{
int i, j;
TERM t, u;
unsigned long temp;
t = bpx_build_structure("$randstate", 4 * N / 3 + 1);
bpx_unify(bpx_get_arg(1, t), bpx_build_integer(mti));
for (i = 0; i < 4 * N / 3; i++) {
j = i / 4 * 3;
temp = 0;
if (i % 4 > 0) {
temp |= mt[j + i % 4 - 1] << (8 * (3 - i % 4));
}
if (i % 4 < 3) {
temp |= mt[j + i % 4 - 0] >> (8 * (1 + i % 4));
}
temp &= 0xFFFFFF; /* == 2^24 - 1 */
u = bpx_get_arg(i + 2, t);
bpx_unify(u, bpx_build_integer(temp));
}
return bpx_unify(ARG(1,1), t);
}
int pc_random_set_state_1(void)
{
int i, j;
TERM term;
unsigned long temp;
term = ARG(1,1);
assert(strcmp(bpx_get_name(term), "$randstate") == 0);
assert(bpx_get_arity(term) == 4 * N / 3 + 1);
mti = bpx_get_integer(bpx_get_arg(1, term));
for (i = 0; i < N; i++) {
j = i / 3 * 4;
mt[i] = 0;
temp = bpx_get_integer(bpx_get_arg(j + i % 3 + 2, term));
mt[i] |= temp << (8 * (1 + i % 3));
temp = bpx_get_integer(bpx_get_arg(j + i % 3 + 3, term));
mt[i] |= temp >> (8 * (2 - i % 3));
mt[i] &= 0xFFFFFFFF;
}
return BP_TRUE;
}
/*--------------------------------------------------------------------*/

14
packages/prism/src/c/core/random.h Normal file
View File

@ -0,0 +1,14 @@
#ifndef RANDOM_H
#define RANDOM_H
#include <stddef.h>
/*--------------------------------------------------------------------*/
int random_int(int);
double random_float(void);
double random_gaussian(double, double);
/*--------------------------------------------------------------------*/
#endif /* RANDOM_H */

23
packages/prism/src/c/core/stuff.h Normal file
View File

@ -0,0 +1,23 @@
#ifndef STUFF_H
#define STUFF_H
/*--------------------------------------------------------------------*/
typedef enum { false, true } bool;
/*--------------------------------------------------------------------*/
#if defined _MSC_VER
#define NORET void __declspec(noreturn)
#define PRINTF_LIKE_FUNC(m, n) /* empty */
#elif defined __GNUC__
#define NORET void __attribute__((noreturn))
#define PRINTF_LIKE_FUNC(m, n) __attribute__((format(printf, m, n)))
#else /* other */
#define NORET void
#define PRINTF_LIKE_FUNC(m, n) /* empty */
#endif
/*--------------------------------------------------------------------*/
#endif /* STUFF_H */

424
packages/prism/src/c/core/termpool.c Normal file
View File

@ -0,0 +1,424 @@
#include <assert.h>
#include "core/termpool.h"
#include "core/xmalloc.h"
#include "core/vector.h"
#include "core/stuff.h"
/* FIXME */
#define prism_quit(msg) quit("*** {PRISM FATAL ERROR: " msg "}\n")
NORET quit(const char *);
/*--------------------------------------------------------------------*/
/* [04 Apr 2009, by yuizumi]
* This value should be sufficiently large enough to have malloc(3)
* return an address with its top bit set on 32-bit Linux systems.
*/
#define BLOCK_SIZE 1048576
/*--------------------------------------------------------------------*/
/* [05 Apr 2009, by yuizumi]
* The area referred by this variable is shared by prism_hash_value()
* and term_pool_store(), under the assumption that BPLONG values and
* BPLONG_PTR values (i.e. pointers) are aligned in the same way even
* without cast operations.
*/
static BPLONG_PTR work;
/*--------------------------------------------------------------------*/
struct term_pool {
BPLONG_PTR head;
BPLONG_PTR curr;
BPLONG_PTR tail;
struct hash_entry **bucks;
size_t nbucks;
size_t count;
};
struct hash_entry {
TERM term;
BPULONG hash;
struct hash_entry *next;
};
/*--------------------------------------------------------------------*/
/* Functions from B-Prolog */
/* mic.c */
void c_STATISTICS(void);
/* table.c */
void numberVarTermOpt(TERM);
TERM unnumberVarTerm(TERM, BPLONG_PTR, BPLONG_PTR);
/* unify.c */
int unifyNumberedTerms(TERM, TERM);
/*--------------------------------------------------------------------*/
static ptrdiff_t trail_pos0 = 0;
static void number_vars(TERM term)
{
assert(trail_pos0 == 0);
trail_pos0 = trail_up_addr - trail_top;
PRE_NUMBER_VAR(0);
numberVarTermOpt(term);
if (number_var_exception != 0) {
prism_quit("suspension variables not supported in Prism");
}
}
static void revert_vars(void)
{
BPLONG_PTR trail_top0;
assert(trail_pos0 != 0);
trail_top0 = trail_up_addr - trail_pos0;
UNDO_TRAILING;
trail_pos0 = 0;
}
/* [29 Mar 2009, by yuizumi]
* See Also: "Algorithms in C, Third Edition," by Robert Sedgewick,
* Addison-Wesley, 1998.
*/
static BPULONG prism_hash_value(TERM term)
{
TERM t, *rest;
BPLONG i, n;
SYM_REC_PTR sym;
BPULONG a = 2130563839ul;
BPULONG b = 1561772629ul;
BPULONG h = 0;
BPULONG u;
rest = (TERM *)work;
VECTOR_PUSH(rest, term);
while (! VECTOR_EMPTY(rest)) {
t = VECTOR_POP(rest);
nderef_loop:
switch (XTAG(t)) {
case REF0:
case REF1:
XNDEREF(t, nderef_loop);
assert(false); /* numbered by number_vars() */
case ATM:
case INT:
case NVAR:
u = (BPULONG)t;
break;
case LST:
VECTOR_PUSH(rest, GET_CDR(t));
VECTOR_PUSH(rest, GET_CAR(t));
u = (BPULONG)LST;
break;
case STR:
sym = GET_STR_SYM_REC(t);
n = GET_ARITY_STR(sym);
for (i = n; i >= 1; i--) {
VECTOR_PUSH(rest, GET_ARG(t, i));
}
u = (BPULONG)ADDTAG(sym, STR);
break;
case SUSP:
assert(false); /* rejected by number_vars() */
default:
assert(false);
}
h = (a * h) + (BPULONG)(u);
a *= b;
}
work = (BPLONG *)rest;
return h;
}
/*--------------------------------------------------------------------*/
static BPLONG_PTR term_pool_allocate(TERM_POOL *this, size_t size)
{
BPLONG_PTR p_tmp;
assert(size <= MAX_ARITY + 1);
if (this->head == NULL || this->curr + size > this->tail) {
BP_MALLOC(p_tmp, BLOCK_SIZE, "(prism part)");
*p_tmp = (BPLONG)(this->head);
this->head = p_tmp + 0;
this->curr = p_tmp + 1;
this->tail = p_tmp + BLOCK_SIZE;
}
p_tmp = this->curr;
this->curr += size;
return p_tmp;
}
/*--------------------------------------------------------------------*/
static TERM term_pool_store(TERM_POOL *this, TERM term)
{
TERM *p, *q, **rest;
BPLONG i, n;
SYM_REC_PTR sym;
rest = (void *)(work);
VECTOR_PUSH(rest, &term);
while (! VECTOR_EMPTY(rest)) {
p = VECTOR_POP(rest);
nderef_loop:
switch (XTAG(*p)) {
case REF0:
case REF1:
XNDEREF(*p, nderef_loop);
assert(false); /* numbered by number_vars() */
case ATM:
case INT:
case NVAR:
break;
case LST:
q = term_pool_allocate(this, 2);
*(q + 1) = GET_CDR(*p);
VECTOR_PUSH(rest, q + 1);
*(q + 0) = GET_CAR(*p);
VECTOR_PUSH(rest, q + 0);
*p = ADDTAG(q, LST);
break;
case STR:
sym = GET_STR_SYM_REC(*p);
n = GET_ARITY_STR(sym);
q = term_pool_allocate(this, n + 1);
*q = (TERM)(sym);
for (i = n; i >= 1; i--) {
*(q + i) = GET_ARG(*p, i);
VECTOR_PUSH(rest, q + i);
}
*p = ADDTAG(q, STR);
break;
case SUSP:
assert(false); /* rejected by number_vars() */
default:
assert(false);
}
}
work = (void *)(rest);
return term;
}
/*--------------------------------------------------------------------*/
static void term_pool_rehash(TERM_POOL *this)
{
struct hash_entry **bucks, *p, *q;
size_t nbucks, i;
nbucks = 2 * this->nbucks + 1;
/* find the next prime number */
for (i = 3; i * i <= nbucks; ) {
if (nbucks % i == 0) {
nbucks += 2;
i = 3;
}
else {
i += 2;
}
}
bucks = MALLOC(sizeof(struct hash_entry *) * nbucks);
for (i = 0; i < nbucks; i++)
bucks[i] = NULL;
for (i = 0; i < this->nbucks; i++) {
p = this->bucks[i];
while (p != NULL) {
q = p;
p = p->next;
q->next = bucks[q->hash % nbucks];
bucks[q->hash % nbucks] = q;
}
}
FREE(this->bucks);
this->nbucks = nbucks;
this->bucks = bucks;
}
/*--------------------------------------------------------------------*/
static TERM term_pool_search(const TERM_POOL *this, TERM term, BPULONG hash)
{
struct hash_entry *p;
p = this->bucks[hash % this->nbucks];
while (p != NULL) {
if (hash == p->hash) {
if (unifyNumberedTerms(term, p->term)) {
return p->term;
}
}
p = p->next;
}
return NULL_TERM;
}
static TERM term_pool_insert(TERM_POOL *this, TERM term, BPULONG hash)
{
struct hash_entry *entry;
if (++(this->count) >= this->nbucks)
term_pool_rehash(this);
entry = MALLOC(sizeof(struct hash_entry));
entry->term = term_pool_store(this, term);
entry->hash = hash;
entry->next = this->bucks[hash % this->nbucks];
this->bucks[hash % this->nbucks] = entry;
return entry->term;
}
/*--------------------------------------------------------------------*/
static TERM term_pool_intern(const TERM_POOL *this1, TERM_POOL *this2, TERM term)
{
BPULONG hash;
TERM rval;
assert(this2 == NULL || this2 == this1);
nderef_loop:
switch (XTAG(term)) {
case REF0:
case REF1:
XNDEREF(term, nderef_loop);
return MAKE_NVAR(0);
case ATM:
case INT:
case NVAR:
return term;
case LST:
case STR:
break;
case SUSP:
prism_quit("suspension variables not supported in Prism");
default:
assert(false);
}
number_vars(term);
hash = prism_hash_value(term);
rval = term_pool_search(this1, term, hash);
if (rval == NULL_TERM && this2 != NULL) {
rval = term_pool_insert(this2, term, hash);
}
revert_vars();
return rval;
}
/*--------------------------------------------------------------------*/
TERM_POOL * term_pool_create(void)
{
TERM_POOL *this;
int i;
this = MALLOC(sizeof(struct term_pool));
this->head = NULL;
this->curr = NULL;
this->tail = NULL;
this->nbucks = 17;
this->count = 0;
this->bucks = MALLOC(sizeof(struct hash_entry *) * this->nbucks);
for (i = 0; i < this->nbucks; i++)
this->bucks[i] = NULL;
if (work == NULL) {
VECTOR_INIT_CAPA(work, 4096);
}
return this;
}
/*--------------------------------------------------------------------*/
void term_pool_delete(TERM_POOL *this)
{
BPLONG_PTR p1, p2;
struct hash_entry *q1, *q2;
int i;
p1 = this->head;
while (p1 != NULL) {
p2 = p1;
p1 = (BPLONG_PTR)(*p1);
FREE(p2);
}
for (i = 0; i < this->nbucks; i++) {
q1 = this->bucks[i];
while (q1 != NULL) {
q2 = q1;
q1 = q1->next;
FREE(q2);
}
}
FREE(this->bucks);
FREE(this);
}
/*--------------------------------------------------------------------*/
TERM term_pool_retrieve(const TERM_POOL *this, TERM term)
{
return term_pool_intern(this, NULL, term);
}
TERM term_pool_register(TERM_POOL *this, TERM term)
{
return term_pool_intern(this, this, term);
}
/*--------------------------------------------------------------------*/

20
packages/prism/src/c/core/termpool.h Normal file
View File

@ -0,0 +1,20 @@
#ifndef TERMPOOL_H
#define TERMPOOL_H
#include "bpx.h"
/*--------------------------------------------------------------------*/
typedef struct term_pool TERM_POOL;
/*--------------------------------------------------------------------*/
TERM_POOL * term_pool_create(void);
void term_pool_delete(TERM_POOL *);
TERM term_pool_retrieve(const TERM_POOL *, TERM);
TERM term_pool_register(TERM_POOL *, TERM);
/*--------------------------------------------------------------------*/
#endif /* TERMPOOL_H */

87
packages/prism/src/c/core/vector.c Normal file
View File

@ -0,0 +1,87 @@
#include "core/xmalloc.h"
#include "core/vector.h"
#include <assert.h>
/*--------------------------------------------------------------------*/
#define INITIAL_CAPA 16
#undef VECTOR_SIZE
#undef VECTOR_CAPA
/* allow these to be L-values */
#define VECTOR_SIZE(v) (((size_t *)(v))[-1])
#define VECTOR_CAPA(v) (((size_t *)(v))[-2])
/*--------------------------------------------------------------------*/
void * vector_create(size_t unit, size_t size, size_t capa)
{
void *ptr, *vec;
ptr = MALLOC(sizeof(size_t) * 2 + unit * capa);
vec = ((size_t *)(ptr)) + 2;
VECTOR_SIZE(vec) = size;
VECTOR_CAPA(vec) = capa;
return vec;
}
void vector_delete(void *vec)
{
free(((size_t *)(vec)) - 2);
}
void * vector_expand(void *vec, size_t unit)
{
size_t capa;
if (VECTOR_SIZE(vec) >= VECTOR_CAPA(vec)) {
capa = VECTOR_CAPA(vec) * 2;
if (capa < INITIAL_CAPA) {
capa = INITIAL_CAPA;
}
vec = vector_realloc(vec, unit, capa);
}
++(VECTOR_SIZE(vec));
return vec;
}
void * vector_reduce(void *vec)
{
assert(VECTOR_SIZE(vec) > 0);
--(VECTOR_SIZE(vec));
return vec;
}
void * vector_resize(void *vec, size_t unit, size_t size)
{
vec = vector_reserve(vec, unit, size);
VECTOR_SIZE(vec) = size;
return vec;
}
void * vector_reserve(void *vec, size_t unit, size_t capa)
{
if (VECTOR_CAPA(vec) < capa) {
vec = vector_realloc(vec, unit, capa);
}
return vec;
}
void * vector_realloc(void *vec, size_t unit, size_t capa)
{
void *ptr;
if (VECTOR_CAPA(vec) == capa)
return vec;
assert(VECTOR_SIZE(vec) <= capa);
ptr = ((size_t *)(vec)) - 2;
ptr = REALLOC(ptr, sizeof(size_t) * 2 + unit * capa);
vec = ((size_t *)(ptr)) + 2;
VECTOR_CAPA(vec) = capa;
return vec;
}
/*--------------------------------------------------------------------*/

59
packages/prism/src/c/core/vector.h Normal file
View File

@ -0,0 +1,59 @@
#ifndef VECTOR_H
#define VECTOR_H
#include "stddef.h"
/*--------------------------------------------------------------------*/
#define VECTOR_INIT(v) \
((v) = vector_create(sizeof(*(v)), 0, 0))
#define VECTOR_INIT_SIZE(v, n) \
((v) = vector_create(sizeof(*(v)), n, n))
#define VECTOR_INIT_CAPA(v, m) \
((v) = vector_create(sizeof(*(v)), 0, m))
#define VECTOR_FREE(v) \
((v) = (vector_delete(v), NULL))
/*--------------------------------------------------------------------*/
#define VECTOR_SIZE(v) \
((size_t)(((const size_t *)(v))[-1]))
#define VECTOR_CAPA(v) \
((size_t)(((const size_t *)(v))[-2]))
#define VECTOR_PUSH(v, x) \
((v) = vector_expand(v, sizeof(*(v))), (v)[VECTOR_SIZE(v) - 1] = (x))
#define VECTOR_POP(v) \
((v) = vector_reduce(v), (v)[VECTOR_SIZE(v)])
#define VECTOR_PUSH_NONE(v) \
((v) = vector_expand(v, sizeof(*(v))))
#define VECTOR_RESIZE(v, n) \
((v) = vector_resize(v, sizeof(*(v)), n))
#define VECTOR_RESERVE(v, m) \
((v) = vector_reserve(v, sizeof(*(v)), m))
#define VECTOR_STRIP(v) \
((v) = vector_realloc(v, sizeof(*(v)), VECTOR_SIZE(v)))
#define VECTOR_CLEAR(v) \
((void)(((const size_t *)(v))[-1] = 0))
#define VECTOR_EMPTY(v) \
(VECTOR_SIZE(v) == 0)
/*--------------------------------------------------------------------*/
void * vector_create(size_t, size_t, size_t);
void vector_delete(void *);
void * vector_expand(void *, size_t);
void * vector_reduce(void *);
void * vector_resize(void *, size_t, size_t);
void * vector_reserve(void *, size_t, size_t);
void * vector_realloc(void *, size_t, size_t);
/*--------------------------------------------------------------------*/
#endif /* VECTOR_H */

35
packages/prism/src/c/core/xmalloc.c Normal file
View File

@ -0,0 +1,35 @@
#include <stdio.h>
#include <stdlib.h>
#include "core/xmalloc.h"
/*--------------------------------------------------------------------*/
void * xmalloc
(size_t size, const char *file, unsigned int line)
{
void *ptr;
ptr = malloc(size);
if (ptr == NULL) {
fprintf(stderr, "Out of memory in %s(%u)\n", file, line);
exit(1); /* FIXME */
}
return ptr;
}
void * xrealloc
(void *oldptr, size_t size, const char *file, unsigned int line)
{
void *newptr;
newptr = realloc(oldptr, size);
if (newptr == NULL && size > 0) {
fprintf(stderr, "Out of memory in %s(%u)\n", file, line);
exit(1); /* FIXME */
}
return newptr;
}
/*--------------------------------------------------------------------*/

25
packages/prism/src/c/core/xmalloc.h Normal file
View File

@ -0,0 +1,25 @@
#ifndef XMALLOC_H
#define XMALLOC_H
#include <stdlib.h>
/*--------------------------------------------------------------------*/
void * xmalloc(size_t, const char *, unsigned int);
void * xrealloc(void *, size_t, const char *, unsigned int);
/*--------------------------------------------------------------------*/
#ifdef MALLOC_TRACE
# define MALLOC(size) malloc((size))
# define REALLOC(oldptr,size) realloc((oldptr),(size))
# define FREE(ptr) (free(ptr), (ptr) = NULL)
#else
# define MALLOC(size) xmalloc((size), __FILE__, __LINE__)
# define REALLOC(oldptr,size) xrealloc((oldptr), (size), __FILE__, __LINE__)
# define FREE(ptr) (free(ptr), (ptr) = NULL)
#endif
/*--------------------------------------------------------------------*/
#endif /* XMALLOC_H */

56
packages/prism/src/c/makefiles/Makefile.files Normal file
View File

@ -0,0 +1,56 @@
# -*- Makefile -*-
##----------------------------------------------------------------------
CORE_OBJS = core$(S)glue.$(O) \
core$(S)bpx.$(O) \
core$(S)idtable.$(O) \
core$(S)idtable_preds.$(O) \
core$(S)termpool.$(O) \
core$(S)vector.$(O) \
core$(S)random.$(O) \
core$(S)gamma.$(O) \
core$(S)xmalloc.$(O) \
core$(S)fputil.$(O) \
core$(S)error.$(O)
UP_OBJS = up$(S)graph.$(O) \
up$(S)graph_aux.$(O) \
up$(S)em_preds.$(O) \
up$(S)em_ml.$(O) \
up$(S)em_vb.$(O) \
up$(S)em_aux.$(O) \
up$(S)em_aux_ml.$(O) \
up$(S)em_aux_vb.$(O) \
up$(S)viterbi.$(O) \
up$(S)hindsight.$(O) \
up$(S)flags.$(O) \
up$(S)util.$(O)
MP_OBJS = mp$(S)mp_core.$(O) \
mp$(S)mp_em_aux.$(O) \
mp$(S)mp_em_ml.$(O) \
mp$(S)mp_em_preds.$(O) \
mp$(S)mp_em_vb.$(O) \
mp$(S)mp_flags.$(O) \
mp$(S)mp_preds.$(O) \
mp$(S)mp_sw.$(O)
OBJS = $(CORE_OBJS) $(UP_OBJS)
##----------------------------------------------------------------------
INSTALLDIR = ..$(S)..$(S)bin
CORE_DIR = core
UP_DIR = up
MP_DIR = mp
SUBDIRS = $(CORE_DIR) $(UP_DIR)
##----------------------------------------------------------------------
#BP4P_A = bp4prism$(S)lib$(S)bp4prism-$(PLATFORM).$(A)
BP4P_A =
##----------------------------------------------------------------------

11
packages/prism/src/c/makefiles/README Normal file
View File

@ -0,0 +1,11 @@
===================== README (src/c/makefiles) =====================
This directory contains the Makefiles which are included into the
Makefiles in the above directory:
Makefile.opts.gmake ... settings for GNU make
Makefile.opts.nmake ... settings for nmake (MSVC++)
Makefile.files ... source file names
If you would like to change the default settings, please modify
these Makefiles.

21
packages/prism/src/c/mp/mp.h Normal file
View File

@ -0,0 +1,21 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef MP_H
#define MP_H
/*-------------------------------------------------------------------------*/
#include <mpi.h>
/*-------------------------------------------------------------------------*/
#define TAG_GOAL_REQ (1)
#define TAG_GOAL_LEN (2)
#define TAG_GOAL_STR (3)
#define TAG_SWITCH_REQ (4)
#define TAG_SWITCH_RES (5)
/*-------------------------------------------------------------------------*/
#endif /* MP_H */

101
packages/prism/src/c/mp/mp_core.c Normal file
View File

@ -0,0 +1,101 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
/* [27 Aug 2007, by yuizumi]
* FIXME: mp_debug() is currently platform-dependent.
*/
#ifdef MPI
#include "up/up.h"
#include "mp/mp.h"
#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
#include <sys/time.h>
#include <unistd.h> /* STDOUT_FILENO */
#include <mpi.h>
/* Currently mpprism works only on Linux systems. */
#define DEV_NULL "/dev/null"
/*-------------------------------------------------------------------------*/
int fd_dup_stdout = -1;
int mp_size;
int mp_rank;
/*-------------------------------------------------------------------------*/
static void close_stdout(void)
{
fd_dup_stdout = dup(STDOUT_FILENO);
if (fd_dup_stdout < 0)
return;
if (freopen(DEV_NULL, "w", stdout) == NULL) {
close(fd_dup_stdout);
fd_dup_stdout = -1;
}
}
/*-------------------------------------------------------------------------*/
void mp_init(int *argc, char **argv[])
{
MPI_Init(argc, argv);
MPI_Comm_size(MPI_COMM_WORLD, &mp_size);
MPI_Comm_rank(MPI_COMM_WORLD, &mp_rank);
if (mp_size < 2) {
printf("Two or more processes required to run mpprism.\n");
MPI_Finalize();
exit(1);
}
if (mp_rank > 0) {
close_stdout();
}
}
void mp_done(void)
{
MPI_Finalize();
}
NORET mp_quit(int status)
{
fprintf(stderr, "The system is aborted by Rank #%d.\n", mp_rank);
MPI_Abort(MPI_COMM_WORLD, status);
exit(status); /* should not reach here */
}
/*-------------------------------------------------------------------------*/
void mp_debug(const char *fmt, ...)
{
#ifdef MP_DEBUG
char str[1024];
va_list ap;
struct timeval tv;
int s, u;
va_start(ap, fmt);
vsnprintf(str, sizeof(str), fmt, ap);
va_end(ap);
gettimeofday(&tv, NULL);
s = tv.tv_sec;
u = tv.tv_usec;
fprintf(stderr, "[RANK:%d] %02d:%02d:%02d.%03d -- %s\n",
mp_rank, (s / 3600) % 24, (s / 60) % 60, s % 60, u / 1000, str);
#endif
}
/*-------------------------------------------------------------------------*/
#endif /* MPI */

19
packages/prism/src/c/mp/mp_core.h Normal file
View File

@ -0,0 +1,19 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef MP_CORE_H
#define MP_CORE_H
/*-------------------------------------------------------------------------*/
extern int mp_size;
extern int mp_rank;
extern int fd_dup_stdout;
/*-------------------------------------------------------------------------*/
void mp_debug(const char *, ...);
NORET mp_quit(int);
/*-------------------------------------------------------------------------*/
#endif /* MP_CORE_H */

256
packages/prism/src/c/mp/mp_em_aux.c Normal file
View File

@ -0,0 +1,256 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifdef MPI
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "up/up.h"
#include "up/em.h"
#include "up/graph.h"
#include "mp/mp.h"
#include "mp/mp_core.h"
#include "mp/mp_sw.h"
#include <stdlib.h>
/*------------------------------------------------------------------------*/
int sw_msg_size = 0;
static void * sw_msg_send = NULL;
static void * sw_msg_recv = NULL;
/*------------------------------------------------------------------------*/
/* mic.c (B-Prolog) */
NORET quit(const char *);
/*------------------------------------------------------------------------*/
void alloc_sw_msg_buffers(void)
{
sw_msg_send = MALLOC(sizeof(double) * sw_msg_size);
sw_msg_recv = MALLOC(sizeof(double) * sw_msg_size);
}
void release_sw_msg_buffers(void)
{
free(sw_msg_send);
sw_msg_send = NULL;
free(sw_msg_recv);
sw_msg_recv = NULL;
}
/*------------------------------------------------------------------------*/
void mpm_bcast_fixed(void)
{
SW_INS_PTR sw_ins_ptr;
char *meg_ptr;
int i;
meg_ptr = sw_msg_send;
for (i = 0; i < occ_switch_tab_size; i++) {
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
*(meg_ptr++) = (!!sw_ins_ptr->fixed) | ((!!sw_ins_ptr->fixed_h) << 1);
}
}
MPI_Bcast(sw_msg_send, sw_msg_size, MPI_CHAR, 0, MPI_COMM_WORLD);
mp_debug("mpm_bcast_fixed");
}
void mps_bcast_fixed(void)
{
SW_INS_PTR sw_ins_ptr;
char *meg_ptr;
int i;
MPI_Bcast(sw_msg_recv, sw_msg_size, MPI_CHAR, 0, MPI_COMM_WORLD);
mp_debug("mps_bcast_fixed");
for (i = 0; i < occ_switch_tab_size; i++) {
meg_ptr = sw_msg_recv;
meg_ptr += occ_position[i];
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
sw_ins_ptr->fixed = !!(*meg_ptr & 1);
sw_ins_ptr->fixed_h = !!(*meg_ptr & 2);
meg_ptr++;
}
}
}
void mpm_bcast_inside(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
meg_ptr = sw_msg_send;
for (i = 0; i < occ_switch_tab_size; i++) {
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
*(meg_ptr++) = sw_ins_ptr->inside;
}
}
MPI_Bcast(sw_msg_send, sw_msg_size, MPI_DOUBLE, 0, MPI_COMM_WORLD);
mp_debug("mpm_bcast_inside");
}
void mps_bcast_inside(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
MPI_Bcast(sw_msg_recv, sw_msg_size, MPI_DOUBLE, 0, MPI_COMM_WORLD);
mp_debug("mps_bcast_inside");
for (i = 0; i < occ_switch_tab_size; i++) {
meg_ptr = sw_msg_recv;
meg_ptr += occ_position[i];
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
sw_ins_ptr->inside = *(meg_ptr++);
}
}
}
void mpm_bcast_inside_h(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
meg_ptr = sw_msg_send;
for (i = 0; i < occ_switch_tab_size; i++) {
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
*(meg_ptr++) = sw_ins_ptr->inside_h;
}
}
MPI_Bcast(sw_msg_send, sw_msg_size, MPI_DOUBLE, 0, MPI_COMM_WORLD);
mp_debug("mpm_bcast_inside_h");
}
void mps_bcast_inside_h(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
MPI_Bcast(sw_msg_recv, sw_msg_size, MPI_DOUBLE, 0, MPI_COMM_WORLD);
mp_debug("mps_bcast_inside_h");
for (i = 0; i < occ_switch_tab_size; i++) {
meg_ptr = sw_msg_recv;
meg_ptr += occ_position[i];
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
sw_ins_ptr->inside_h = *(meg_ptr++);
}
}
}
void mpm_bcast_smooth(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
meg_ptr = sw_msg_send;
for (i = 0; i < occ_switch_tab_size; i++) {
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
*(meg_ptr++) = sw_ins_ptr->smooth;
}
}
MPI_Bcast(sw_msg_send, sw_msg_size, MPI_DOUBLE, 0, MPI_COMM_WORLD);
mp_debug("mpm_bcast_smooth");
}
void mps_bcast_smooth(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
MPI_Bcast(sw_msg_recv, sw_msg_size, MPI_DOUBLE, 0, MPI_COMM_WORLD);
mp_debug("mps_bcast_smooth");
for (i = 0; i < occ_switch_tab_size; i++) {
meg_ptr = sw_msg_recv;
meg_ptr += occ_position[i];
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
sw_ins_ptr->smooth = *(meg_ptr++);
}
}
}
/*------------------------------------------------------------------------*/
void clear_sw_msg_send(void)
{
double *meg_ptr;
double *end_ptr;
meg_ptr = sw_msg_send;
end_ptr = meg_ptr + sw_msg_size;
while (meg_ptr != end_ptr) {
*(meg_ptr++) = 0.0;
}
}
void mpm_share_expectation(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
MPI_Allreduce(sw_msg_send, sw_msg_recv, sw_msg_size, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD);
meg_ptr = sw_msg_recv;
for (i = 0; i < occ_switch_tab_size; i++) {
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
sw_ins_ptr->total_expect = *(meg_ptr++);
}
}
}
void mps_share_expectation(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
for (i = 0; i < occ_switch_tab_size; i++) {
meg_ptr = sw_msg_send;
meg_ptr += occ_position[i];
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
*(meg_ptr++) = sw_ins_ptr->total_expect;
}
}
MPI_Allreduce(sw_msg_send, sw_msg_recv, sw_msg_size, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD);
for (i = 0; i < occ_switch_tab_size; i++) {
meg_ptr = sw_msg_recv;
meg_ptr += occ_position[i];
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
sw_ins_ptr->total_expect = *(meg_ptr++);
}
}
}
double mp_sum_value(double value)
{
double g_value;
MPI_Allreduce(&value, &g_value, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD);
return g_value;
}
/*------------------------------------------------------------------------*/
#endif /* MPI */

29
packages/prism/src/c/mp/mp_em_aux.h Normal file
View File

@ -0,0 +1,29 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef MP_EM_AUX_H
#define MP_EM_AUX_H
/*-------------------------------------------------------------------------*/
extern int sw_msg_size;
/*-------------------------------------------------------------------------*/
void alloc_sw_msg_buffers(void);
void release_sw_msg_buffers(void);
void mpm_bcast_fixed(void);
void mps_bcast_fixed(void);
void mpm_bcast_inside(void);
void mps_bcast_inside(void);
void mpm_bcast_inside_h(void);
void mps_bcast_inside_h(void);
void mpm_bcast_smooth(void);
void mps_bcast_smooth(void);
void clear_sw_msg_send(void);
void mpm_share_expectation(void);
void mps_share_expectation(void);
double mp_sum_value(double);
/*-------------------------------------------------------------------------*/
#endif /* MP_EM_AUX_H */

265
packages/prism/src/c/mp/mp_em_ml.c Normal file
View File

@ -0,0 +1,265 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifdef MPI
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "core/error.h"
#include "up/up.h"
#include "up/em.h"
#include "up/em_aux.h"
#include "up/em_aux_ml.h"
#include "up/em_ml.h"
#include "up/graph.h"
#include "up/flags.h"
#include "up/util.h"
#include "mp/mp.h"
#include "mp/mp_core.h"
#include "mp/mp_em_aux.h"
#include <mpi.h>
/*------------------------------------------------------------------------*/
void mpm_share_preconds_em(int *smooth)
{
int ivals[4];
int ovals[4];
ivals[0] = sw_msg_size;
ivals[1] = 0;
ivals[2] = 0;
ivals[3] = *smooth;
MPI_Allreduce(ivals, ovals, 4, MPI_INT, MPI_SUM, MPI_COMM_WORLD);
sw_msg_size = ovals[0];
num_goals = ovals[1];
failure_observed = ovals[2];
*smooth = ovals[3];
mp_debug("msgsize=%d, #goals=%d, failure=%s, smooth = %s",
sw_msg_size, num_goals, failure_observed ? "on" : "off", *smooth ? "on" : "off");
alloc_sw_msg_buffers();
mpm_bcast_fixed();
if (*smooth) {
mpm_bcast_smooth();
}
}
void mps_share_preconds_em(int *smooth)
{
int ivals[4];
int ovals[4];
ivals[0] = 0;
ivals[1] = num_goals;
ivals[2] = failure_observed;
ivals[3] = 0;
MPI_Allreduce(ivals, ovals, 4, MPI_INT, MPI_SUM, MPI_COMM_WORLD);
sw_msg_size = ovals[0];
num_goals = ovals[1];
failure_observed = ovals[2];
*smooth = ovals[3];
mp_debug("msgsize=%d, #goals=%d, failure=%s, smooth = %s",
sw_msg_size, num_goals, failure_observed ? "on" : "off", *smooth ? "on" : "off");
alloc_sw_msg_buffers();
mps_bcast_fixed();
if (*smooth) {
mps_bcast_smooth();
}
}
/*------------------------------------------------------------------------*/
int mpm_run_em(EM_ENG_PTR emptr)
{
int r, iterate, old_valid, converged, saved=0;
double likelihood, log_prior;
double lambda, old_lambda=0.0;
config_em(emptr);
for (r = 0; r < num_restart; r++) {
SHOW_PROGRESS_HEAD("#em-iters", r);
initialize_params();
mpm_bcast_inside();
clear_sw_msg_send();
itemp = daem ? itemp_init : 1.0;
iterate = 0;
while (1) {
if (daem) {
SHOW_PROGRESS_TEMP(itemp);
}
old_valid = 0;
while (1) {
if (CTRLC_PRESSED) {
SHOW_PROGRESS_INTR();
RET_ERR(err_ctrl_c_pressed);
}
if (failure_observed) {
inside_failure = mp_sum_value(0.0);
}
log_prior = emptr->smooth ? emptr->compute_log_prior() : 0.0;
lambda = mp_sum_value(log_prior);
likelihood = lambda - log_prior;
mp_debug("local lambda = %.9f, lambda = %.9f", log_prior, lambda);
if (verb_em) {
if (emptr->smooth) {
prism_printf("Iteration #%d:\tlog_likelihood=%.9f\tlog_prior=%.9f\tlog_post=%.9f\n", iterate, likelihood, log_prior, lambda);
}
else {
prism_printf("Iteration #%d:\tlog_likelihood=%.9f\n", iterate, likelihood);
}
}
if (!isfinite(lambda)) {
emit_internal_error("invalid log likelihood or log post: %s (at iterateion #%d)",
isnan(lambda) ? "NaN" : "infinity", iterate);
RET_ERR(ierr_invalid_likelihood);
}
if (old_valid && old_lambda - lambda > prism_epsilon) {
emit_error("log likelihood or log post decreased [old: %.9f, new: %.9f] (at iteration #%d)",
old_lambda, lambda, iterate);
RET_ERR(err_invalid_likelihood);
}
if (itemp == 1.0 && likelihood > 0.0) {
emit_error("log likelihood greater than zero [value: %.9f] (at iteration #%d)",
likelihood, iterate);
RET_ERR(err_invalid_likelihood);
}
converged = (old_valid && lambda - old_lambda <= prism_epsilon);
if (converged || REACHED_MAX_ITERATE(iterate)) {
break;
}
old_lambda = lambda;
old_valid = 1;
mpm_share_expectation();
SHOW_PROGRESS(iterate);
RET_ON_ERR(emptr->update_params());
iterate++;
}
if (itemp == 1.0) {
break;
}
itemp *= itemp_rate;
if (itemp >= 1.0) {
itemp = 1.0;
}
}
SHOW_PROGRESS_TAIL(converged, iterate, lambda);
if (r == 0 || lambda > emptr->lambda) {
emptr->lambda = lambda;
emptr->likelihood = likelihood;
emptr->iterate = iterate;
saved = (r < num_restart - 1);
if (saved) {
save_params();
}
}
}
if (saved) {
restore_params();
}
emptr->bic = compute_bic(emptr->likelihood);
emptr->cs = emptr->smooth ? compute_cs(emptr->likelihood) : 0.0;
return BP_TRUE;
}
int mps_run_em(EM_ENG_PTR emptr)
{
int r, iterate, old_valid, converged, saved=0;
double likelihood;
double lambda, old_lambda=0.0;
config_em(emptr);
for (r = 0; r < num_restart; r++) {
mps_bcast_inside();
clear_sw_msg_send();
itemp = daem ? itemp_init : 1.0;
iterate = 0;
while (1) {
old_valid = 0;
while (1) {
RET_ON_ERR(emptr->compute_inside());
RET_ON_ERR(emptr->examine_inside());
if (failure_observed) {
inside_failure = mp_sum_value(inside_failure);
}
likelihood = emptr->compute_likelihood();
lambda = mp_sum_value(likelihood);
mp_debug("local lambda = %.9f, lambda = %.9f", likelihood, lambda);
converged = (old_valid && lambda - old_lambda <= prism_epsilon);
if (converged || REACHED_MAX_ITERATE(iterate)) {
break;
}
old_lambda = lambda;
old_valid = 1;
RET_ON_ERR(emptr->compute_expectation());
mps_share_expectation();
RET_ON_ERR(emptr->update_params());
iterate++;
}
if (itemp == 1.0) {
break;
}
itemp *= itemp_rate;
if (itemp >= 1.0) {
itemp = 1.0;
}
}
if (r == 0 || lambda > emptr->lambda) {
emptr->lambda = lambda;
saved = (r < num_restart - 1);
if (saved) {
save_params();
}
}
}
if (saved) {
restore_params();
}
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
#endif /* MPI */

15
packages/prism/src/c/mp/mp_em_ml.h Normal file
View File

@ -0,0 +1,15 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef MP_EM_ML_H
#define MP_EM_ML_H
/*-------------------------------------------------------------------------*/
void mpm_share_preconds_em(int *);
void mps_share_preconds_em(int *);
int mpm_run_em(EM_ENG_PTR);
int mps_run_em(EM_ENG_PTR);
/*-------------------------------------------------------------------------*/
#endif /* MP_EM_ML_H */

167
packages/prism/src/c/mp/mp_em_preds.c Normal file
View File

@ -0,0 +1,167 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifdef MPI
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "up/up.h"
#include "up/em.h"
#include "up/em_aux.h"
#include "up/em_aux_ml.h"
#include "up/em_aux_vb.h"
#include "up/graph.h"
#include "up/flags.h"
#include "mp/mp.h"
#include "mp/mp_core.h"
#include "mp/mp_em_aux.h"
#include "mp/mp_em_ml.h"
#include "mp/mp_em_vb.h"
#include "mp/mp_sw.h"
#include <mpi.h>
/*------------------------------------------------------------------------*/
/* mic.c (B-Prolog) */
NORET myquit(int, const char *);
/*------------------------------------------------------------------------*/
int pc_mpm_prism_em_6(void)
{
struct EM_Engine em_eng;
/* [28 Aug 2007, by yuizumi]
* occ_switches[] will be freed in pc_import_occ_switches/1.
* occ_position[] is not allocated.
*/
RET_ON_ERR(check_smooth(&em_eng.smooth));
mpm_share_preconds_em(&em_eng.smooth);
RET_ON_ERR(mpm_run_em(&em_eng));
release_sw_msg_buffers();
release_num_sw_vals();
return
bpx_unify(bpx_get_call_arg(1,6), bpx_build_integer(em_eng.iterate)) &&
bpx_unify(bpx_get_call_arg(2,6), bpx_build_float(em_eng.lambda)) &&
bpx_unify(bpx_get_call_arg(3,6), bpx_build_float(em_eng.likelihood)) &&
bpx_unify(bpx_get_call_arg(4,6), bpx_build_float(em_eng.bic)) &&
bpx_unify(bpx_get_call_arg(5,6), bpx_build_float(em_eng.cs)) &&
bpx_unify(bpx_get_call_arg(6,6), bpx_build_integer(em_eng.smooth));
}
int pc_mps_prism_em_0(void)
{
struct EM_Engine em_eng;
mps_share_preconds_em(&em_eng.smooth);
RET_ON_ERR(mps_run_em(&em_eng));
release_sw_msg_buffers();
release_occ_switches();
release_num_sw_vals();
release_occ_position();
return BP_TRUE;
}
int pc_mpm_prism_vbem_2(void)
{
struct VBEM_Engine vb_eng;
RET_ON_ERR(check_smooth_vb());
mpm_share_preconds_vbem();
RET_ON_ERR(mpm_run_vbem(&vb_eng));
release_sw_msg_buffers();
release_num_sw_vals();
return
bpx_unify(bpx_get_call_arg(1,2), bpx_build_integer(vb_eng.iterate)) &&
bpx_unify(bpx_get_call_arg(2,2), bpx_build_float(vb_eng.free_energy));
}
int pc_mps_prism_vbem_0(void)
{
struct VBEM_Engine vb_eng;
mps_share_preconds_vbem();
RET_ON_ERR(mps_run_vbem(&vb_eng));
release_sw_msg_buffers();
release_occ_switches();
release_num_sw_vals();
release_occ_position();
return BP_TRUE;
}
int pc_mpm_prism_both_em_2(void)
{
struct VBEM_Engine vb_eng;
RET_ON_ERR(check_smooth_vb());
mpm_share_preconds_vbem();
RET_ON_ERR(mpm_run_vbem(&vb_eng));
get_param_means();
release_sw_msg_buffers();
release_num_sw_vals();
return
bpx_unify(bpx_get_call_arg(1,2), bpx_build_integer(vb_eng.iterate)) &&
bpx_unify(bpx_get_call_arg(2,2), bpx_build_float(vb_eng.free_energy));
}
int pc_mps_prism_both_em_0(void)
{
struct VBEM_Engine vb_eng;
mps_share_preconds_vbem();
RET_ON_ERR(mps_run_vbem(&vb_eng));
get_param_means();
release_sw_msg_buffers();
release_occ_switches();
release_num_sw_vals();
release_occ_position();
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
int pc_mpm_import_graph_stats_4(void)
{
int dummy[4] = { 0 };
int stats[4];
double avg_shared;
MPI_Reduce(dummy, stats, 4, MPI_INT, MPI_SUM, 0, MPI_COMM_WORLD);
avg_shared = (double)(stats[3]) / stats[0];
return
bpx_unify(bpx_get_call_arg(1,4), bpx_build_integer(stats[0])) &&
bpx_unify(bpx_get_call_arg(2,4), bpx_build_integer(stats[1])) &&
bpx_unify(bpx_get_call_arg(3,4), bpx_build_integer(stats[2])) &&
bpx_unify(bpx_get_call_arg(4,4), bpx_build_float(avg_shared));
}
int pc_mps_import_graph_stats_0(void)
{
int dummy[4];
int stats[4];
graph_stats(stats);
MPI_Reduce(stats, dummy, 4, MPI_INT, MPI_SUM, 0, MPI_COMM_WORLD);
mp_debug("# subgoals = %d", stats[0]);
mp_debug("# goal nodes = %d", stats[1]);
mp_debug("# switch nodes = %d", stats[2]);
mp_debug("# sharings = %d", stats[3]);
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
#endif /* MPI */

19
packages/prism/src/c/mp/mp_em_preds.h Normal file
View File

@ -0,0 +1,19 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef MP_EM_PREDS_H
#define MP_EM_PREDS_H
/*-------------------------------------------------------------------------*/
int pc_mpm_prism_em_6(void);
int pc_mps_prism_em_0(void);
int pc_mpm_prism_vbem_2(void);
int pc_mps_prism_vbem_0(void);
int pc_mpm_prism_both_em_7(void);
int pc_mps_prism_both_em_0(void);
int pc_mpm_import_graph_stats_4(void);
int pc_mps_import_graph_stats_0(void);
/*-------------------------------------------------------------------------*/
#endif /* MP_EM_PREDS_H */

256
packages/prism/src/c/mp/mp_em_vb.c Normal file
View File

@ -0,0 +1,256 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifdef MPI
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "up/up.h"
#include "up/em.h"
#include "up/em_aux.h"
#include "up/em_aux_vb.h"
#include "up/em_vb.h"
#include "up/graph.h"
#include "up/flags.h"
#include "up/util.h"
#include "mp/mp.h"
#include "mp/mp_core.h"
#include "mp/mp_em_aux.h"
#include <mpi.h>
/*------------------------------------------------------------------------*/
void mpm_share_preconds_vbem(void)
{
int ivals[3];
int ovals[3];
ivals[0] = sw_msg_size;
ivals[1] = 0;
ivals[2] = 0;
MPI_Allreduce(ivals, ovals, 3, MPI_INT, MPI_SUM, MPI_COMM_WORLD);
sw_msg_size = ovals[0];
num_goals = ovals[1];
failure_observed = ovals[2];
mp_debug("msgsize=%d, #goals=%d, failure=%s",
sw_msg_size, num_goals, failure_observed ? "on" : "off");
alloc_sw_msg_buffers();
mpm_bcast_fixed();
}
void mps_share_preconds_vbem(void)
{
int ivals[3];
int ovals[3];
ivals[0] = 0;
ivals[1] = num_goals;
ivals[2] = failure_observed;
MPI_Allreduce(ivals, ovals, 3, MPI_INT, MPI_SUM, MPI_COMM_WORLD);
sw_msg_size = ovals[0];
num_goals = ovals[1];
failure_observed = ovals[2];
mp_debug("msgsize=%d, #goals=%d, failure=%s",
sw_msg_size, num_goals, failure_observed ? "on" : "off");
alloc_sw_msg_buffers();
mps_bcast_fixed();
}
/*------------------------------------------------------------------------*/
int mpm_run_vbem(VBEM_ENG_PTR vbptr)
{
int r, iterate, old_valid, converged, saved=0;
double free_energy, old_free_energy=0.0;
double l0, l1;
config_vbem(vbptr);
for (r = 0; r < num_restart; r++) {
SHOW_PROGRESS_HEAD("#vbem-iters", r);
initialize_hyperparams();
mpm_bcast_inside_h();
mpm_bcast_smooth();
clear_sw_msg_send();
itemp = daem ? itemp_init : 1.0;
iterate = 0;
while (1) {
if (daem) {
SHOW_PROGRESS_TEMP(itemp);
}
old_valid = 0;
while (1) {
if (CTRLC_PRESSED) {
SHOW_PROGRESS_INTR();
RET_ERR(err_ctrl_c_pressed);
}
RET_ON_ERR(vbptr->compute_pi());
if (failure_observed) {
inside_failure = mp_sum_value(0.0);
}
l0 = vbptr->compute_free_energy_l0();
l1 = vbptr->compute_free_energy_l1();
free_energy = mp_sum_value(l0 - l1);
mp_debug("local free_energy = %.9f, free_energy = %.9f", l0 - l1, free_energy);
if (verb_em) {
prism_printf("Iteration #%d:\tfree_energy=%.9f\n", iterate, free_energy);
}
if (!isfinite(free_energy)) {
emit_internal_error("invalid variational free energy: %s (at iteration #%d)",
isnan(free_energy) ? "NaN" : "infinity", iterate);
RET_ERR(err_invalid_free_energy);
}
if (old_valid && old_free_energy - free_energy > prism_epsilon) {
emit_error("variational free energy decreased [old: %.9f, new: %.9f] (at iteration #%d)",
old_free_energy, free_energy, iterate);
RET_ERR(err_invalid_free_energy);
}
if (itemp == 1.0 && free_energy > 0.0) {
emit_error("variational free energy greater than zero [value: %.9f] (at iteration #%d)",
free_energy, iterate);
RET_ERR(err_invalid_free_energy);
}
converged = (old_valid && free_energy - old_free_energy <= prism_epsilon);
if (converged || REACHED_MAX_ITERATE(iterate)) {
break;
}
old_free_energy = free_energy;
old_valid = 1;
mpm_share_expectation();
SHOW_PROGRESS(iterate);
RET_ON_ERR(vbptr->update_hyperparams());
iterate++;
}
if (itemp == 1.0) {
break;
}
itemp *= itemp_rate;
if (itemp >= 1.0) {
itemp = 1.0;
}
}
SHOW_PROGRESS_TAIL(converged, iterate, free_energy);
if (r == 0 || free_energy > vbptr->free_energy) {
vbptr->free_energy = free_energy;
vbptr->iterate = iterate;
saved = (r < num_restart - 1);
if (saved) {
save_hyperparams();
}
}
}
if (saved) {
restore_hyperparams();
}
transfer_hyperparams();
return BP_TRUE;
}
int mps_run_vbem(VBEM_ENG_PTR vbptr)
{
int r, iterate, old_valid, converged, saved=0;
double free_energy, old_free_energy=0.0;
double l2;
config_vbem(vbptr);
for (r = 0; r < num_restart; r++) {
mps_bcast_inside_h();
mps_bcast_smooth();
clear_sw_msg_send();
itemp = daem ? itemp_init : 1.0;
iterate = 0;
while (1) {
old_valid = 0;
while (1) {
RET_ON_ERR(vbptr->compute_pi());
RET_ON_ERR(vbptr->compute_inside());
RET_ON_ERR(vbptr->examine_inside());
if (failure_observed) {
inside_failure = mp_sum_value(inside_failure);
}
l2 = vbptr->compute_likelihood() / itemp;
free_energy = mp_sum_value(l2);
mp_debug("local free_energy = %.9f, free_energy = %.9f", l2, free_energy);
converged = (old_valid && free_energy - old_free_energy <= prism_epsilon);
if (converged || REACHED_MAX_ITERATE(iterate)) {
break;
}
old_free_energy = free_energy;
old_valid = 1;
RET_ON_ERR(vbptr->compute_expectation());
mps_share_expectation();
RET_ON_ERR(vbptr->update_hyperparams());
iterate++;
}
if (itemp == 1.0) {
break;
}
itemp *= itemp_rate;
if (itemp >= 1.0) {
itemp = 1.0;
}
}
if (r == 0 || free_energy > vbptr->free_energy) {
vbptr->free_energy = free_energy;
saved = (r < num_restart - 1);
if (saved) {
save_hyperparams();
}
}
}
if (saved) {
restore_hyperparams();
}
transfer_hyperparams();
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
#endif /* MPI */

15
packages/prism/src/c/mp/mp_em_vb.h Normal file
View File

@ -0,0 +1,15 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef MP_EM_VB_H
#define MP_EM_VB_H
/*-------------------------------------------------------------------------*/
void mpm_share_preconds_vbem(void);
void mps_share_preconds_vbem(void);
int mpm_run_vbem(VBEM_ENG_PTR);
int mps_run_vbem(VBEM_ENG_PTR);
/*-------------------------------------------------------------------------*/
#endif /* MP_EM_VB_H */

77
packages/prism/src/c/mp/mp_flags.c Normal file
View File

@ -0,0 +1,77 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifdef MPI
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "up/flags.h"
#include <mpi.h>
/*------------------------------------------------------------------------*/
#define PUT(msg,pos,type,value) \
MPI_Pack(&(value),1,(type),(msg),sizeof(msg),&(pos),MPI_COMM_WORLD)
#define GET(msg,pos,type,value) \
MPI_Unpack((msg),sizeof(msg),&(pos),&(value),1,(type),MPI_COMM_WORLD)
/*------------------------------------------------------------------------*/
int pc_mpm_share_prism_flags_0(void)
{
char msg[256];
int pos = 0;
PUT( msg , pos , MPI_INT , daem );
PUT( msg , pos , MPI_INT , em_message );
PUT( msg , pos , MPI_INT , em_progress );
PUT( msg , pos , MPI_INT , error_on_cycle );
PUT( msg , pos , MPI_INT , fix_init_order );
PUT( msg , pos , MPI_INT , init_method );
PUT( msg , pos , MPI_DOUBLE , itemp_init );
PUT( msg , pos , MPI_DOUBLE , itemp_rate );
PUT( msg , pos , MPI_INT , log_scale );
PUT( msg , pos , MPI_INT , max_iterate );
PUT( msg , pos , MPI_INT , num_restart );
PUT( msg , pos , MPI_DOUBLE , prism_epsilon );
PUT( msg , pos , MPI_DOUBLE , std_ratio );
PUT( msg , pos , MPI_INT , verb_em );
PUT( msg , pos , MPI_INT , verb_graph );
PUT( msg , pos , MPI_INT , warn );
MPI_Bcast(msg, sizeof(msg), MPI_PACKED, 0, MPI_COMM_WORLD);
return BP_TRUE;
}
int pc_mps_share_prism_flags_0(void)
{
char msg[256];
int pos = 0;
MPI_Bcast(msg, sizeof(msg), MPI_PACKED, 0, MPI_COMM_WORLD);
GET( msg , pos , MPI_INT , daem );
GET( msg , pos , MPI_INT , em_message );
GET( msg , pos , MPI_INT , em_progress );
GET( msg , pos , MPI_INT , error_on_cycle );
GET( msg , pos , MPI_INT , fix_init_order );
GET( msg , pos , MPI_INT , init_method );
GET( msg , pos , MPI_DOUBLE , itemp_init );
GET( msg , pos , MPI_DOUBLE , itemp_rate );
GET( msg , pos , MPI_INT , log_scale );
GET( msg , pos , MPI_INT , max_iterate );
GET( msg , pos , MPI_INT , num_restart );
GET( msg , pos , MPI_DOUBLE , prism_epsilon );
GET( msg , pos , MPI_DOUBLE , std_ratio );
GET( msg , pos , MPI_INT , verb_em );
GET( msg , pos , MPI_INT , verb_graph );
GET( msg , pos , MPI_INT , warn );
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
#endif /* MPI */

13
packages/prism/src/c/mp/mp_flags.h Normal file
View File

@ -0,0 +1,13 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef MP_FLAGS_H
#define MP_FLAGS_H
/*-------------------------------------------------------------------------*/
int pc_mpm_share_prism_flags_0(void);
int pc_mps_share_prism_flags_0(void);
/*-------------------------------------------------------------------------*/
#endif /* MP_FLAGS_H */

191
packages/prism/src/c/mp/mp_preds.c Normal file
View File

@ -0,0 +1,191 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifdef MPI
#include "bprolog.h"
#include "core/error.h"
#include "up/up.h"
#include "mp/mp.h"
#include "mp/mp_core.h"
#include <unistd.h> /* STDOUT_FILENO */
#include <string.h>
#include <mpi.h>
/*------------------------------------------------------------------------*/
/* cpred.c (B-Prolog) */
int bp_string_2_term(const char *, TERM, TERM);
/*------------------------------------------------------------------------*/
static char str_prealloc[65536];
/*------------------------------------------------------------------------*/
static int send_term(TERM arg, int mode, int rank)
{
char *str;
int len;
str = (char *)bpx_term_2_string(arg);
len = strlen(str);
switch (mode) {
case 0:
MPI_Send (&len, 1 , MPI_INT , rank, TAG_GOAL_LEN, MPI_COMM_WORLD);
MPI_Send ( str, len, MPI_CHAR, rank, TAG_GOAL_STR, MPI_COMM_WORLD);
break;
case 1:
MPI_Bcast(&len, 1 , MPI_INT , rank, MPI_COMM_WORLD);
MPI_Bcast( str, len, MPI_CHAR, rank, MPI_COMM_WORLD);
break;
}
mp_debug("SEND(%d,%d): %s", mode, rank, str);
return BP_TRUE;
}
static int recv_term(TERM arg, int mode, int rank)
{
char *str;
TERM op1, op2;
int len, res;
switch (mode) {
case 0:
MPI_Recv (&len, 1, MPI_INT, rank, TAG_GOAL_LEN, MPI_COMM_WORLD, NULL);
break;
case 1:
MPI_Bcast(&len, 1, MPI_INT, rank, MPI_COMM_WORLD);
break;
}
if (len < sizeof(str_prealloc))
str = str_prealloc;
else {
str = MALLOC(len + 1);
}
switch (mode) {
case 0:
MPI_Recv (str, len, MPI_CHAR, rank, TAG_GOAL_STR, MPI_COMM_WORLD, NULL);
break;
case 1:
MPI_Bcast(str, len, MPI_CHAR, rank, MPI_COMM_WORLD);
break;
}
*(str + len) = '\0';
mp_debug("RECV(%d,%d): %s", mode, rank, str);
op1 = bpx_build_var();
op2 = bpx_build_var();
res = bp_string_2_term(str,op1,op2);
if (str != str_prealloc) {
free(str);
}
if (res == BP_TRUE) {
return bpx_unify(arg, op1);
}
return res;
}
/*------------------------------------------------------------------------*/
int pc_mp_size_1(void)
{
return bpx_unify(bpx_get_call_arg(1,1), bpx_build_integer(mp_size));
}
int pc_mp_rank_1(void)
{
return bpx_unify(bpx_get_call_arg(1,1), bpx_build_integer(mp_rank));
}
int pc_mp_master_0(void)
{
return (mp_rank == 0) ? BP_TRUE : BP_FALSE;
}
int pc_mp_abort_0(void)
{
mp_quit(0);
}
int pc_mp_wtime_1(void)
{
return bpx_unify(bpx_get_call_arg(1,1), bpx_build_float(MPI_Wtime()));
}
int pc_mp_sync_2(void)
{
int args[2], amin[2], amax[2];
args[0] = bpx_get_integer(bpx_get_call_arg(1,2)); /* tag */
args[1] = bpx_get_integer(bpx_get_call_arg(2,2)); /* sync-id */
mp_debug("SYNC(%d,%d): BGN", args[0], args[1]);
MPI_Allreduce(args, amin, 2, MPI_INT, MPI_MIN, MPI_COMM_WORLD);
MPI_Allreduce(args, amax, 2, MPI_INT, MPI_MAX, MPI_COMM_WORLD);
if (amin[0] != amax[0]) {
emit_internal_error("failure on sync (%d,%d)", args[0], args[1]);
RET_INTERNAL_ERR;
}
if (amin[1] < 0) {
return BP_FALSE;
}
if (amin[1] != amax[1]) {
emit_internal_error("failure on sync (%d,%d)", args[0], args[1]);
RET_INTERNAL_ERR;
}
mp_debug("SYNC(%d,%d): END", args[0], args[1]);
return BP_TRUE;
}
int pc_mp_send_goal_1(void)
{
MPI_Status status;
MPI_Recv(NULL, 0, MPI_INT, MPI_ANY_SOURCE, TAG_GOAL_REQ, MPI_COMM_WORLD, &status);
return send_term(bpx_get_call_arg(1,1), 0, status.MPI_SOURCE);
}
int pc_mp_recv_goal_1(void)
{
MPI_Send(NULL, 0, MPI_INT, 0, TAG_GOAL_REQ, MPI_COMM_WORLD);
return recv_term(bpx_get_call_arg(1,1), 0, 0);
}
int pc_mpm_bcast_command_1(void)
{
return send_term(bpx_get_call_arg(1,1), 1, 0);
}
int pc_mps_bcast_command_1(void)
{
return recv_term(bpx_get_call_arg(1,1), 1, 0);
}
int pc_mps_revert_stdout_0(void)
{
if (fd_dup_stdout >= 0) {
dup2(fd_dup_stdout, STDOUT_FILENO);
close(fd_dup_stdout);
fd_dup_stdout = -1;
}
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
#endif /* MPI */

22
packages/prism/src/c/mp/mp_preds.h Normal file
View File

@ -0,0 +1,22 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef MP_PREDS_H
#define MP_PREDS_H
/*-------------------------------------------------------------------------*/
int pc_mp_size_1(void);
int pc_mp_rank_1(void);
int pc_mp_master_0(void);
int pc_mp_abort_0(void);
int pc_mp_wtime_1(void);
int pc_mp_sync_2(void);
int pc_mp_send_goal_1(void);
int pc_mp_recv_goal_1(void);
int pc_mpm_bcast_command_1(void);
int pc_mps_bcast_command_1(void);
int pc_mps_revert_stdout_0(void);
/*-------------------------------------------------------------------------*/
#endif /* MP_PREDS_H */

206
packages/prism/src/c/mp/mp_sw.c Normal file
View File

@ -0,0 +1,206 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifdef MPI
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "core/idtable.h"
#include "core/idtable_preds.h"
#include "up/up.h"
#include "up/em_aux.h"
#include "up/graph.h"
#include "up/flags.h"
#include "mp/mp.h"
#include "mp/mp_core.h"
#include "mp/mp_em_aux.h"
#include <mpi.h>
#include <stdlib.h>
#include <string.h>
/*------------------------------------------------------------------------*/
int *occ_position = NULL;
static int * sizes = NULL;
static int ** swids = NULL;
#define L(i) (sizes[i * 2 + 0]) /* length of the message from RANK #i */
#define N(i) (sizes[i * 2 + 1]) /* number of switches in RANK #i*/
/*------------------------------------------------------------------------*/
/* cpred.c (B-Prolog) */
int bp_string_2_term(const char *, TERM, TERM);
/* mic.c (B-Prolog) */
NORET quit(const char *);
/*------------------------------------------------------------------------*/
static void parse_switch_req(const char *msg, int src)
{
const char *p;
TERM op1, op2;
int i;
swids[src] = MALLOC(sizeof(int) * N(src));
p = msg;
for (i = 0; i < N(src); i++) {
op1 = bpx_build_var();
op2 = bpx_build_var();
bp_string_2_term(p, op1, op2);
swids[src][i] = prism_sw_id_register(op1);
while (*(p++) != '\0') ;
}
}
/*------------------------------------------------------------------------*/
int pc_mp_send_switches_0(void)
{
char *msg, *str;
TERM msw;
int msglen, msgsiz;
int vals[2];
int i, n;
msglen = 0;
msgsiz = 65536;
msg = MALLOC(msgsiz);
for (i = 0; i < occ_switch_tab_size; i++) {
msw = bpx_get_arg(1, prism_sw_ins_term(occ_switches[i]->id));
str = (char *)bpx_term_2_string(msw);
n = strlen(str) + 1;
if (msgsiz <= msglen + n) {
msgsiz = (msglen + n + 65536) & ~65535;
msg = REALLOC(msg, msgsiz);
}
strcpy(msg + msglen, str);
msglen += n;
}
msg[msglen++] = '\0'; /* this is safe */
vals[0] = msglen;
vals[1] = occ_switch_tab_size;
MPI_Gather(vals, 2, MPI_INT, NULL, 0, MPI_INT, 0, MPI_COMM_WORLD);
MPI_Send(msg, msglen, MPI_CHAR, 0, TAG_SWITCH_REQ, MPI_COMM_WORLD);
free(msg);
return BP_TRUE;
}
int pc_mp_recv_switches_0(void)
{
int i, lmax, vals[2];
char *msg;
sizes = MALLOC(sizeof(int) * 2 * mp_size);
swids = MALLOC(sizeof(int *) * mp_size);
MPI_Gather(vals, 2, MPI_INT, sizes, 2, MPI_INT, 0, MPI_COMM_WORLD);
lmax = 0;
for (i = 1; i < mp_size; i++) {
if (lmax < L(i)) {
lmax = L(i);
}
}
msg = MALLOC(lmax);
for (i = 1; i < mp_size; i++) {
MPI_Recv(msg, L(i), MPI_CHAR, i, TAG_SWITCH_REQ, MPI_COMM_WORLD, NULL);
parse_switch_req(msg, i);
}
free(msg);
return BP_TRUE;
}
int pc_mp_send_swlayout_0(void)
{
int i, j, *msg, *pos;
msg = MALLOC(sizeof(int) * sw_tab_size);
pos = MALLOC(sizeof(int) * sw_ins_tab_size);
j = 0;
for (i = 0; i < occ_switch_tab_size; i++) {
pos[occ_switches[i]->id] = j;
j += num_sw_vals[i];
}
sw_msg_size = j;
for (i = 1; i < mp_size; i++) {
for (j = 0; j < N(i); j++) {
msg[j] = pos[switches[swids[i][j]]->id];
}
MPI_Send(msg, N(i), MPI_INT, i, TAG_SWITCH_RES, MPI_COMM_WORLD);
free(swids[i]);
}
free(pos);
free(msg);
free(sizes);
free(swids);
return BP_TRUE;
}
int pc_mp_recv_swlayout_0(void)
{
occ_position = MALLOC(sizeof(int) * occ_switch_tab_size);
MPI_Recv(occ_position, occ_switch_tab_size, MPI_INT, 0, TAG_SWITCH_RES, MPI_COMM_WORLD, NULL);
/* debug */
{
int i;
TERM msw;
for (i = 0; i < occ_switch_tab_size; i++) {
msw = bpx_get_arg(1, prism_sw_ins_term(occ_switches[i]->id));
mp_debug("%s -> %d", bpx_term_2_string(msw), occ_position[i]);
}
}
return BP_TRUE;
}
int pc_mpm_alloc_occ_switches_0(void)
{
occ_switches = MALLOC(sizeof(SW_INS_PTR) * sw_tab_size);
occ_switch_tab_size = sw_tab_size;
memcpy(occ_switches, switches, sizeof(SW_INS_PTR) * sw_tab_size);
if (fix_init_order) {
sort_occ_switches();
}
alloc_num_sw_vals();
return BP_TRUE;
}
void release_occ_position(void)
{
free(occ_position);
occ_position = NULL;
}
/*------------------------------------------------------------------------*/
#endif /* MPI */

22
packages/prism/src/c/mp/mp_sw.h Normal file
View File

@ -0,0 +1,22 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef MP_SW_H
#define MP_SW_H
/*-------------------------------------------------------------------------*/
extern int *occ_position;
/*-------------------------------------------------------------------------*/
int pc_mp_send_switches_0(void);
int pc_mp_recv_switches_0(void);
int pc_mp_send_swlayout_0(void);
int pc_mp_recv_swlayout_0(void);
int pc_mpm_alloc_occ_switches_0(void);
void release_occ_position(void);
/*-------------------------------------------------------------------------*/
#endif /* MP_SW_H */

106
packages/prism/src/c/up/em.h Normal file
View File

@ -0,0 +1,106 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef __EM_H__
#define __EM_H__
/*------------------------------------------------------------------------*/
#define DEFAULT_MAX_ITERATE (10000)
/*------------------------------------------------------------------------*/
struct EM_Engine {
int smooth; /* [in ] flag: use MAP? */
double lambda; /* [out] log post */
double likelihood; /* [out] log likelihood */
int iterate; /* [out] number of iterations */
double bic; /* [out] BIC score */
double cs; /* [out] CS score */
/* Functions called during computation. */
int (* compute_inside )(void);
int (* examine_inside )(void);
int (* compute_expectation )(void);
double (* compute_likelihood )(void);
double (* compute_log_prior )(void);
int (* update_params )(void);
};
struct VBEM_Engine {
double free_energy; /* [out] free energy */
int iterate; /* [out] number of iterations */
/* Functions called during computation. */
int (* compute_pi )(void);
int (* compute_inside )(void);
int (* examine_inside )(void);
int (* compute_expectation )(void);
double (* compute_free_energy_l0 )(void);
double (* compute_free_energy_l1 )(void);
double (* compute_likelihood )(void);
int (* update_hyperparams )(void);
};
typedef struct EM_Engine * EM_ENG_PTR;
typedef struct VBEM_Engine * VBEM_ENG_PTR;
/*------------------------------------------------------------------------*/
#define SHOW_PROGRESS(n) \
do { \
if(!verb_em && em_message > 0 && (n) % em_progress == 0) { \
if((n) % (em_progress * 10) == 0) \
prism_printf("%d", n); \
else \
prism_printf("."); \
} \
} while (0)
#define SHOW_PROGRESS_HEAD(str, r) \
do { \
if(num_restart > 1) { \
if(verb_em) \
prism_printf("<<<< RESTART #%d >>>>\n", r); \
else if(em_message > 0) \
prism_printf("[%d] ", r); \
} \
if(!verb_em && em_message > 0) \
prism_printf("%s: ", str); \
} while (0)
#define SHOW_PROGRESS_TAIL(converged, n, x) \
do { \
const char *str = \
converged ? "Converged" : "Stopped"; \
\
if(verb_em) \
prism_printf("* %s (%.9f)\n", str, x); \
else if(em_message > 0) \
prism_printf("(%d) (%s: %.9f)\n", n, str, x); \
} while (0)
#define SHOW_PROGRESS_TEMP(x) \
do { \
if(verb_em) \
prism_printf("* Temperature = %.3f\n", x); \
else if(em_message > 0 && show_itemp) \
prism_printf("<%.3f>", x); \
else \
prism_printf("*"); \
} while (0)
#define SHOW_PROGRESS_INTR() \
do { \
if(verb_em) \
prism_printf("* Interrupted\n"); \
else if(em_message > 0) \
prism_printf("(Interrupted)\n"); \
} while (0)
#define REACHED_MAX_ITERATE(n) \
((max_iterate == -1 && (n) >= DEFAULT_MAX_ITERATE) || \
(max_iterate >= +1 && (n) >= max_iterate))
/*------------------------------------------------------------------------*/
#endif /* __EM_H__ */

151
packages/prism/src/c/up/em_aux.c Normal file
View File

@ -0,0 +1,151 @@
/* -*- c-basic-offset: 2; tab-width: 8 -*- */
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "up/up.h"
#include "up/graph.h"
#include "up/flags.h"
/*------------------------------------------------------------------------*/
int * num_sw_vals = NULL;
double itemp;
double inside_failure;
int failure_observed;
/*------------------------------------------------------------------------*/
/* mic.c (B-Prolog) */
int compare(TERM,TERM);
void quit(const char *);
/*------------------------------------------------------------------------*/
/* for sort_occ_switches() */
static int compare_sw_ins(const void *a, const void *b)
{
SW_INS_PTR sw_ins_a, sw_ins_b;
TERM msw_a, msw_b;
sw_ins_a = *(const SW_INS_PTR *)(a);
sw_ins_b = *(const SW_INS_PTR *)(b);
msw_a = prism_sw_ins_term(sw_ins_a->id);
msw_b = prism_sw_ins_term(sw_ins_b->id);
return compare(bpx_get_arg(1,msw_a), bpx_get_arg(1,msw_b));
}
/*------------------------------------------------------------------------*/
/* Set flags of switches appearing in the e-graphs and allocate an array
* of pointers to such switches (This routine is based on compute_inside()).
*/
void alloc_occ_switches(void)
{
int i,j,k;
EG_NODE_PTR eg_ptr;
EG_PATH_PTR path_ptr;
SW_INS_PTR sw_ins_ptr;
int *occ_sw_flags;
int b;
/* Initialize the `occ' counters in switch instances */
for (i = 0; i < sw_ins_tab_size; i++) {
switch_instances[i]->occ = 0;
}
for (i = 0; i < sorted_egraph_size; i++) {
eg_ptr = sorted_expl_graph[i];
path_ptr = eg_ptr->path_ptr;
while (path_ptr != NULL) {
for (k = 0; k < path_ptr->sws_len; k++) {
path_ptr->sws[k]->occ = 1;
}
path_ptr = path_ptr->next;
}
}
/* Temporarily make an array of flags each of which indicates whether
a switch (not switch instance) occurs in the e-graphs */
occ_sw_flags = (int *)MALLOC(sizeof(int) * sw_tab_size);
occ_switch_tab_size = 0;
for (i = 0; i < sw_tab_size; i++) {
sw_ins_ptr = switches[i];
b = 0;
while (sw_ins_ptr != NULL) {
b |= sw_ins_ptr->occ;
sw_ins_ptr = sw_ins_ptr->next;
}
occ_sw_flags[i] = b;
if (b) occ_switch_tab_size++;
}
occ_switches =
(SW_INS_PTR *)MALLOC(sizeof(SW_INS_PTR) * occ_switch_tab_size);
j = 0;
for (i = 0; i < sw_tab_size; i++) {
if (occ_sw_flags[i]) {
occ_switches[j] = switches[i]; /* Copy */
j++;
}
}
free(occ_sw_flags);
}
void sort_occ_switches(void)
{
qsort(occ_switches,occ_switch_tab_size,sizeof(SW_INS_PTR),compare_sw_ins);
}
void release_occ_switches(void)
{
free(occ_switches);
occ_switches = NULL;
}
void alloc_num_sw_vals(void)
{
int i,n;
SW_INS_PTR sw_ins_ptr;
num_sw_vals = (int *)MALLOC(sizeof(int) * occ_switch_tab_size);
for (i = 0; i < occ_switch_tab_size; i++) {
sw_ins_ptr = occ_switches[i];
n = 0;
while (sw_ins_ptr != NULL) {
n++;
sw_ins_ptr = sw_ins_ptr->next;
}
num_sw_vals[i] = n;
}
}
void release_num_sw_vals(void)
{
free(num_sw_vals);
num_sw_vals = NULL;
}
/*------------------------------------------------------------------------*/
void transfer_hyperparams_prolog(void)
{
int i;
SW_INS_PTR sw_ins_ptr;
for (i = 0; i < occ_switch_tab_size; i++) {
sw_ins_ptr = occ_switches[i];
while (sw_ins_ptr != NULL) {
sw_ins_ptr->smooth = sw_ins_ptr->smooth_prolog;
sw_ins_ptr->inside_h = sw_ins_ptr->smooth_prolog + 1.0;
sw_ins_ptr = sw_ins_ptr->next;
}
}
}
/*------------------------------------------------------------------------*/

16
packages/prism/src/c/up/em_aux.h Normal file
View File

@ -0,0 +1,16 @@
#ifndef EM_AUX_H
#define EM_AUX_H
extern int * num_sw_vals; /* #-vals of switches that occur in e-graphs */
extern double itemp; /* inversed temperature (for DAEM) */
extern double inside_failure; /* inside prob. of failure */
extern int failure_observed; /* flag: true if failure is observed */
void alloc_occ_switches(void);
void sort_occ_switches(void);
void release_occ_switches(void);
void alloc_num_sw_vals(void);
void release_num_sw_vals(void);
void transfer_hyperparams_prolog(void);
#endif /* EM_AUX_H */

777
packages/prism/src/c/up/em_aux_ml.c Normal file
View File

@ -0,0 +1,777 @@
/* -*- c-basic-offset: 2; tab-width: 8 -*- */
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "core/random.h"
#include "core/gamma.h"
#include "up/up.h"
#include "up/graph.h"
#include "up/flags.h"
#include "up/em_aux.h"
#include "up/util.h"
/*------------------------------------------------------------------------*/
/* We check if all smoothing constants are positive (MAP),
* or all smoothing constants are zero. If some are positive,
* but the others are zero, die immediately. We also check
* if there exist parameters fixed at zero in MAP estimation.
*/
int check_smooth(int *smooth)
{
/*
q = +4 : found non-zero smoothing constants
+2 : found zero-valued smoothing constants
+1 : found parameters fixed to zero
*/
int i, q = 0;
SW_INS_PTR sw_ins_ptr;
for (i = 0; i < occ_switch_tab_size; i++) {
sw_ins_ptr = occ_switches[i];
while (sw_ins_ptr != NULL) {
if (sw_ins_ptr->smooth_prolog < 0) {
emit_error("negative delta values in MAP estimation");
RET_ERR(err_invalid_numeric_value);
}
q |= (sw_ins_ptr->smooth_prolog < TINY_PROB) ? 2 : 4;
q |= (sw_ins_ptr->fixed && sw_ins_ptr->inside < TINY_PROB) ? 1 : 0;
sw_ins_ptr = sw_ins_ptr->next;
}
}
switch (q) {
case 0: /* p.counts = (none), w/o 0-valued params */
case 1: /* p.counts = (none), with 0-valued params */
emit_internal_error("unexpected case in check_smooth()");
RET_ERR(ierr_unmatched_branches);
case 2: /* p.counts = 0 only, w/o 0-valued params */
case 3: /* p.counts = 0 only, with 0-valued params */
*smooth = 0;
break;
case 4: /* p.counts = + only, w/o 0-valued params */
*smooth = 1;
break;
case 5: /* p.counts = + only, with 0-valued params */
emit_error("parameters fixed to zero in MAP estimation");
RET_ERR(err_invalid_numeric_value);
case 6: /* p.counts = (both), w/o 0-valued params */
case 7: /* p.counts = (both), with 0-valued params */
emit_error("mixture of zero and non-zero pseudo counts");
RET_ERR(err_invalid_numeric_value);
}
transfer_hyperparams_prolog();
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
static void initialize_params_noisy_uniform(void)
{
int i;
SW_INS_PTR ptr;
double sum,p;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
if (ptr->fixed > 0) continue;
p = 1.0 / num_sw_vals[i];
sum = 0.0;
while (ptr != NULL) {
ptr->inside = random_gaussian(p, std_ratio * p);
if (ptr->inside < INIT_PROB_THRESHOLD)
ptr->inside = INIT_PROB_THRESHOLD;
sum += ptr->inside;
ptr = ptr->next;
}
ptr = occ_switches[i];
while (ptr != NULL) { /* normalize */
ptr->inside = ptr->inside / sum;
ptr = ptr->next;
}
}
}
static void initialize_params_random(void)
{
int i;
SW_INS_PTR ptr;
double sum,p;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
if (ptr->fixed > 0) continue;
p = 1.0 / num_sw_vals[i];
sum = 0.0;
while (ptr != NULL) {
sum += (ptr->inside = p + random_float());
ptr = ptr->next;
}
ptr = occ_switches[i];
while (ptr != NULL) { /* normalize */
ptr->inside = ptr->inside / sum;
ptr = ptr->next;
}
}
}
void initialize_params(void)
{
if (init_method == 1)
initialize_params_noisy_uniform();
if (init_method == 2)
initialize_params_random();
}
/*------------------------------------------------------------------------*/
int compute_inside_scaling_none(void)
{
int i,k;
double sum,this_path_inside;
EG_NODE_PTR eg_ptr;
EG_PATH_PTR path_ptr;
for (i = 0; i < sorted_egraph_size; i++) {
eg_ptr = sorted_expl_graph[i];
sum = 0.0;
path_ptr = eg_ptr->path_ptr;
if (path_ptr == NULL)
sum = 1.0; /* path_ptr should not be NULL; but it happens */
while (path_ptr != NULL) {
this_path_inside = 1.0;
for (k = 0; k < path_ptr->children_len; k++) {
this_path_inside *= path_ptr->children[k]->inside;
}
for (k = 0; k < path_ptr->sws_len; k++) {
this_path_inside *= path_ptr->sws[k]->inside;
}
path_ptr->inside = this_path_inside;
sum += this_path_inside;
path_ptr = path_ptr->next;
}
eg_ptr->inside = sum;
}
return BP_TRUE;
}
int compute_inside_scaling_log_exp(void)
{
int i,k,u;
double sum, this_path_inside, first_path_inside = 0.0, sum_rest;
EG_NODE_PTR eg_ptr;
EG_PATH_PTR path_ptr;
for (i = 0; i < sorted_egraph_size; i++) {
eg_ptr = sorted_expl_graph[i];
path_ptr = eg_ptr->path_ptr;
if (path_ptr == NULL) {
sum = 0.0; /* path_ptr should not be NULL; but it happens */
}
else {
sum_rest = 0.0;
u = 0;
while (path_ptr != NULL) {
this_path_inside = 0.0;
for (k = 0; k < path_ptr->children_len; k++) {
this_path_inside += path_ptr->children[k]->inside;
}
for (k = 0; k < path_ptr->sws_len; k++) {
this_path_inside += log(path_ptr->sws[k]->inside);
}
path_ptr->inside = this_path_inside;
if (u == 0) {
first_path_inside = this_path_inside;
sum_rest += 1.0;
}
else if (this_path_inside - first_path_inside >= log(HUGE_PROB)) {
sum_rest *= exp(first_path_inside - this_path_inside);
first_path_inside = this_path_inside;
sum_rest += 1.0; /* maybe sum_rest gets 1.0 */
}
else {
sum_rest += exp(this_path_inside - first_path_inside);
}
path_ptr = path_ptr->next;
u++;
}
sum = first_path_inside + log(sum_rest);
}
eg_ptr->inside = sum;
}
return BP_TRUE;
}
int compute_daem_inside_scaling_none(void)
{
int i,k;
double sum,this_path_inside;
EG_NODE_PTR eg_ptr;
EG_PATH_PTR path_ptr;
for (i = 0; i < sorted_egraph_size; i++) {
eg_ptr = sorted_expl_graph[i];
sum = 0.0;
path_ptr = eg_ptr->path_ptr;
if (path_ptr == NULL)
sum = 1.0; /* path_ptr should not be NULL; but it happens */
while (path_ptr != NULL) {
this_path_inside = 1.0;
for (k = 0; k < path_ptr->children_len; k++) {
this_path_inside *= path_ptr->children[k]->inside;
}
for (k = 0; k < path_ptr->sws_len; k++) {
this_path_inside *= pow(path_ptr->sws[k]->inside, itemp);
}
path_ptr->inside = this_path_inside;
sum += this_path_inside;
path_ptr = path_ptr->next;
}
eg_ptr->inside = sum;
}
return BP_TRUE;
}
int compute_daem_inside_scaling_log_exp(void)
{
int i,k,u;
double sum, this_path_inside, first_path_inside = 0.0, sum_rest;
EG_NODE_PTR eg_ptr;
EG_PATH_PTR path_ptr;
for (i = 0; i < sorted_egraph_size; i++) {
eg_ptr = sorted_expl_graph[i];
path_ptr = eg_ptr->path_ptr;
if (path_ptr == NULL) {
sum = 0.0; /* path_ptr should not be NULL; but it happens */
}
else {
sum_rest = 0.0;
u = 0;
while (path_ptr != NULL) {
this_path_inside = 0.0;
for (k = 0; k < path_ptr->children_len; k++) {
this_path_inside += path_ptr->children[k]->inside;
}
for (k = 0; k < path_ptr->sws_len; k++) {
this_path_inside += itemp * log(path_ptr->sws[k]->inside);
}
path_ptr->inside = this_path_inside;
if (u == 0) {
first_path_inside = this_path_inside;
sum_rest += 1.0;
}
else if (this_path_inside - first_path_inside >= log(HUGE_PROB)) {
sum_rest *= exp(first_path_inside - this_path_inside);
first_path_inside = this_path_inside;
sum_rest += 1.0; /* maybe sum_rest gets 1.0 */
}
else {
sum_rest += exp(this_path_inside - first_path_inside);
}
path_ptr = path_ptr->next;
u++;
}
sum = first_path_inside + log(sum_rest);
}
eg_ptr->inside = sum;
}
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
int examine_inside_scaling_none(void)
{
int i;
double inside;
inside_failure = 0.0;
for (i = 0; i < num_roots; i++) {
inside = expl_graph[roots[i]->id]->inside;
if (i == failure_root_index) {
inside_failure = inside;
if (!(1.0 - inside_failure > 0.0)) {
emit_error("Probability of failure being unity");
RET_ERR(err_invalid_numeric_value);
}
}
else {
if (!(inside > 0.0)) {
emit_error("Probability of an observed goal being zero");
RET_ERR(err_invalid_numeric_value);
}
}
}
return BP_TRUE;
}
int examine_inside_scaling_log_exp(void)
{
int i;
double inside;
/* [23 Aug 2007, by yuizumi]
* By the code below, inside_failure can take only a non-zero value
* when `failure' is observed. We can therefore safely use zero as
* an indicator of failure being not observed. Zero is chosen just
* for convenience in implementation of the parallel version.
*/
inside_failure = 0.0;
for (i = 0; i < num_roots; i++) {
inside = expl_graph[roots[i]->id]->inside;
if (i == failure_root_index) {
inside_failure = inside; /* log-scale */
if (!(inside_failure < 0.0)) {
emit_error("Probability of failure being unity");
RET_ERR(err_invalid_numeric_value);
}
}
else {
if (!isfinite(inside)) {
emit_error("Probability of an observed goal being zero");
RET_ERR(err_invalid_numeric_value);
}
}
}
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
int compute_expectation_scaling_none(void)
{
int i,k;
EG_PATH_PTR path_ptr;
EG_NODE_PTR eg_ptr,node_ptr;
SW_INS_PTR sw_ptr;
double q;
for (i = 0; i < sw_ins_tab_size; i++) {
switch_instances[i]->total_expect = 0.0;
}
for (i = 0; i < sorted_egraph_size; i++) {
sorted_expl_graph[i]->outside = 0.0;
}
for (i = 0; i < num_roots; i++) {
eg_ptr = expl_graph[roots[i]->id];
if (i == failure_root_index) {
eg_ptr->outside = num_goals / (1.0 - inside_failure);
}
else {
eg_ptr->outside = roots[i]->count / eg_ptr->inside;
}
}
for (i = sorted_egraph_size - 1; i >= 0; i--) {
eg_ptr = sorted_expl_graph[i];
path_ptr = eg_ptr->path_ptr;
while (path_ptr != NULL) {
q = eg_ptr->outside * path_ptr->inside;
if (q > 0.0) {
for (k = 0; k < path_ptr->children_len; k++) {
node_ptr = path_ptr->children[k];
node_ptr->outside += q / node_ptr->inside;
}
for (k = 0; k < path_ptr->sws_len; k++) {
sw_ptr = path_ptr->sws[k];
sw_ptr->total_expect += q;
}
}
path_ptr = path_ptr->next;
}
}
return BP_TRUE;
}
int compute_expectation_scaling_log_exp(void)
{
int i,k;
EG_PATH_PTR path_ptr;
EG_NODE_PTR eg_ptr,node_ptr;
SW_INS_PTR sw_ptr;
double q,r;
for (i = 0; i < sw_ins_tab_size; i++) {
switch_instances[i]->total_expect = 0.0;
switch_instances[i]->has_first_expectation = 0;
switch_instances[i]->first_expectation = 0.0;
}
for (i = 0; i < sorted_egraph_size; i++) {
sorted_expl_graph[i]->outside = 0.0;
sorted_expl_graph[i]->has_first_outside = 0;
sorted_expl_graph[i]->first_outside = 0.0;
}
for (i = 0; i < num_roots; i++) {
eg_ptr = expl_graph[roots[i]->id];
if (i == failure_root_index) {
eg_ptr->first_outside =
log(num_goals / (1.0 - exp(inside_failure)));
}
else {
eg_ptr->first_outside =
log((double)(roots[i]->count)) - eg_ptr->inside;
}
eg_ptr->has_first_outside = 1;
eg_ptr->outside = 1.0;
}
/* sorted_expl_graph[to] must be a root node */
for (i = sorted_egraph_size - 1; i >= 0; i--) {
eg_ptr = sorted_expl_graph[i];
/* First accumulate log-scale outside probabilities: */
if (!eg_ptr->has_first_outside) {
emit_internal_error("unexpected has_first_outside[%s]",
prism_goal_string(eg_ptr->id));
RET_INTERNAL_ERR;
}
else if (!(eg_ptr->outside > 0.0)) {
emit_internal_error("unexpected outside[%s]",
prism_goal_string(eg_ptr->id));
RET_INTERNAL_ERR;
}
else {
eg_ptr->outside = eg_ptr->first_outside + log(eg_ptr->outside);
}
path_ptr = sorted_expl_graph[i]->path_ptr;
while (path_ptr != NULL) {
q = sorted_expl_graph[i]->outside + path_ptr->inside;
for (k = 0; k < path_ptr->children_len; k++) {
node_ptr = path_ptr->children[k];
r = q - node_ptr->inside;
if (!node_ptr->has_first_outside) {
node_ptr->first_outside = r;
node_ptr->outside += 1.0;
node_ptr->has_first_outside = 1;
}
else if (r - node_ptr->first_outside >= log(HUGE_PROB)) {
node_ptr->outside *= exp(node_ptr->first_outside - r);
node_ptr->first_outside = r;
node_ptr->outside += 1.0;
}
else {
node_ptr->outside += exp(r - node_ptr->first_outside);
}
}
for (k = 0; k < path_ptr->sws_len; k++) {
sw_ptr = path_ptr->sws[k];
if (!sw_ptr->has_first_expectation) {
sw_ptr->first_expectation = q;
sw_ptr->total_expect += 1.0;
sw_ptr->has_first_expectation = 1;
}
else if (q - sw_ptr->first_expectation >= log(HUGE_PROB)) {
sw_ptr->total_expect *= exp(sw_ptr->first_expectation - q);
sw_ptr->first_expectation = q;
sw_ptr->total_expect += 1.0;
}
else {
sw_ptr->total_expect += exp(q - sw_ptr->first_expectation);
}
}
path_ptr = path_ptr->next;
}
}
/* unscale total_expect */
for (i = 0; i < sw_ins_tab_size; i++) {
sw_ptr = switch_instances[i];
if (!sw_ptr->has_first_expectation) continue;
if (!(sw_ptr->total_expect > 0.0)) {
emit_error("unexpected expectation for %s",prism_sw_ins_string(i));
RET_ERR(err_invalid_numeric_value);
}
sw_ptr->total_expect =
exp(sw_ptr->first_expectation + log(sw_ptr->total_expect));
}
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
double compute_likelihood_scaling_none(void)
{
int i;
double likelihood,adjuster,inside;
likelihood = 0.0;
adjuster = failure_observed ? log(1.0-inside_failure) : 0.0;
for (i = 0; i < num_roots; i++) {
if (i == failure_root_index) continue; /* skip failure */
inside = expl_graph[roots[i]->id]->inside; /* always positive */
likelihood += roots[i]->count * (log(inside) - adjuster);
}
return likelihood;
}
double compute_likelihood_scaling_log_exp(void)
{
int i;
double likelihood,adjuster,inside;
likelihood = 0.0;
adjuster = failure_observed ? log(1.0-exp(inside_failure)) : 0.0;
for (i = 0; i < num_roots; i++) {
if (i == failure_root_index) continue; /* skip failure */
inside = expl_graph[roots[i]->id]->inside; /* log-scale */
likelihood += roots[i]->count * (inside - adjuster);
}
return likelihood;
}
/*------------------------------------------------------------------------*/
double compute_log_prior(void)
{
int i;
SW_INS_PTR sw_ins_ptr;
double lp;
lp = 0.0;
for (i = 0; i < occ_switch_tab_size; i++) {
sw_ins_ptr = occ_switches[i];
while (sw_ins_ptr != NULL) {
lp += sw_ins_ptr->smooth * log(sw_ins_ptr->inside);
sw_ins_ptr = sw_ins_ptr->next;
}
}
return lp;
}
double compute_daem_log_prior(void)
{
int i;
SW_INS_PTR sw_ins_ptr;
double lp;
lp = 0.0;
for (i = 0; i < occ_switch_tab_size; i++) {
sw_ins_ptr = occ_switches[i];
while (sw_ins_ptr != NULL) {
lp += sw_ins_ptr->smooth * log(sw_ins_ptr->inside);
sw_ins_ptr = sw_ins_ptr->next;
}
}
return itemp * lp;
}
/*------------------------------------------------------------------------*/
int update_params(void)
{
int i;
SW_INS_PTR ptr,next;
double sum,cur_prob_sum;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
sum = 0.0;
while (ptr != NULL) {
sum += ptr->total_expect;
ptr = ptr->next;
}
if (sum != 0.0) {
cur_prob_sum = 0.0;
ptr = occ_switches[i];
if (ptr->fixed > 0) continue;
next = ptr->next;
while (next != NULL) {
if (ptr->fixed == 0) ptr->inside = ptr->total_expect / sum;
if (log_scale && ptr->inside < log(TINY_PROB)) {
emit_error("Parameter being zero (-inf in log scale) -- %s",
prism_sw_ins_string(ptr->id));
RET_ERR(err_underflow);
}
cur_prob_sum += ptr->inside;
ptr = next;
next = ptr->next;
}
ptr->inside = 1.0-cur_prob_sum; /* Normalize */
}
}
return BP_TRUE;
}
int update_params_smooth(void)
{
int i;
SW_INS_PTR ptr,next;
double sum,cur_prob_sum;
double denom;
int n;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
n = num_sw_vals[i];
sum = 0.0;
while (ptr != NULL) {
sum += ptr->total_expect + ptr->smooth;
ptr = ptr->next;
}
denom = sum;
if (sum != 0.0) {
cur_prob_sum = 0.0;
ptr = occ_switches[i];
if (ptr->fixed > 0) continue;
next = ptr->next;
while (next != NULL) {
if (ptr->fixed == 0)
ptr->inside = (ptr->total_expect + ptr->smooth) / denom;
cur_prob_sum += ptr->inside;
ptr = next;
next = ptr->next;
}
ptr->inside = 1.0-cur_prob_sum; /* Normalize */
}
}
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
void save_params(void)
{
int i;
SW_INS_PTR ptr;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
if (ptr->fixed > 0) continue;
while (ptr != NULL) {
ptr->best_inside = ptr->inside;
ptr->best_total_expect = ptr->total_expect;
ptr = ptr->next;
}
}
}
void restore_params(void)
{
int i;
SW_INS_PTR ptr;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
if (ptr->fixed > 0) continue;
while (ptr != NULL) {
ptr->inside = ptr->best_inside;
ptr->total_expect = ptr->best_total_expect;
ptr = ptr->next;
}
}
}
/*------------------------------------------------------------------------*/
double compute_bic(double likelihood)
{
double bic = likelihood;
int i, num_sw_ins, num_params;
num_sw_ins = 0;
for (i = 0; i < occ_switch_tab_size; i++) {
SW_INS_PTR ptr = occ_switches[i];
while (ptr != NULL) {
num_sw_ins++;
ptr = ptr->next;
}
}
/* Get the number of free parameters: */
num_params = num_sw_ins - occ_switch_tab_size;
bic = likelihood - 0.5 * num_params * log(num_goals);
return bic;
}
double compute_cs(double likelihood)
{
double cs;
double l0, l1, l2;
int i;
SW_INS_PTR ptr;
double smooth_sum;
/* Compute BD score using the expectations: */
l0 = 0.0;
for (i = 0; i < occ_switch_tab_size; i++) {
smooth_sum = 0.0;
ptr = occ_switches[i];
while (ptr != NULL) {
smooth_sum += (ptr->smooth + 1.0);
ptr = ptr->next;
}
l0 += lngamma(smooth_sum);
smooth_sum = 0.0;
ptr = occ_switches[i];
while (ptr != NULL) {
smooth_sum += (ptr->total_expect + ptr->smooth + 1.0);
ptr = ptr->next;
}
l0 -= lngamma(smooth_sum);
ptr = occ_switches[i];
while (ptr != NULL) {
l0 += lngamma(ptr->total_expect + ptr->smooth + 1.0);
l0 -= lngamma(ptr->smooth + 1.0);
ptr = ptr->next;
}
}
/* Compute the likelihood of complete data using the expectations: */
l1 = 0.0;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
while (ptr != NULL) {
l1 += ptr->total_expect * log(ptr->inside);
ptr = ptr->next;
}
}
/* Get the log-likelihood: */
l2 = likelihood;
cs = l0 - l1 + l2;
return cs;
}
/*------------------------------------------------------------------------*/

26
packages/prism/src/c/up/em_aux_ml.h Normal file
View File

@ -0,0 +1,26 @@
#ifndef EM_AUX_ML_H
#define EM_AUX_ML_H
int check_smooth(int *);
void initialize_params(void);
int compute_inside_scaling_none(void);
int compute_inside_scaling_log_exp(void);
int compute_daem_inside_scaling_none(void);
int compute_daem_inside_scaling_log_exp(void);
int examine_inside_scaling_none(void);
int examine_inside_scaling_log_exp(void);
int compute_expectation_scaling_none(void);
int compute_expectation_scaling_log_exp(void);
double compute_likelihood_scaling_none(void);
double compute_likelihood_scaling_log_exp(void);
double compute_log_prior(void);
double compute_daem_log_prior(void);
int update_params(void);
int update_params_smooth(void);
void save_params(void);
void restore_params(void);
double compute_bic(double);
double compute_cs(double);
#endif /* EM_AUX_ML_H */

569
packages/prism/src/c/up/em_aux_vb.c Normal file
View File

@ -0,0 +1,569 @@
/* -*- c-basic-offset: 2; tab-width: 8 -*- */
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "core/random.h"
#include "core/gamma.h"
#include "up/up.h"
#include "up/graph.h"
#include "up/em_aux.h"
#include "up/em_aux_ml.h"
#include "up/flags.h"
#include "up/util.h"
/*------------------------------------------------------------------------*/
/* Just check if there is any negative hyperparameter */
int check_smooth_vb(void)
{
int i;
SW_INS_PTR sw_ins_ptr;
for (i = 0; i < occ_switch_tab_size; i++) {
sw_ins_ptr = occ_switches[i];
while (sw_ins_ptr != NULL) {
if (sw_ins_ptr->smooth_prolog <= -1.0) {
emit_internal_error("illegal hyperparameters");
RET_INTERNAL_ERR;
}
sw_ins_ptr = sw_ins_ptr->next;
}
}
transfer_hyperparams_prolog();
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
void initialize_hyperparams(void)
{
int i;
SW_INS_PTR ptr;
double p,r;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
while (ptr != NULL) {
ptr->smooth = ptr->smooth_prolog;
ptr = ptr->next;
}
}
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
if (ptr->fixed_h > 0) {
while (ptr != NULL) {
ptr->inside_h = ptr->smooth + 1.0;
ptr->total_expect = 0.0;
ptr = ptr->next;
}
}
else {
p = 1.0 / num_sw_vals[i];
while (ptr != NULL) {
r = random_gaussian(0.0, std_ratio * p);
ptr->inside_h =
(ptr->smooth + 1.0 < EPS) ? EPS : ptr->smooth + 1.0;
ptr->inside_h *= (1.0 + fabs(r));
ptr->smooth = ptr->inside_h - 1.0;
ptr->total_expect = 0.0;
ptr = ptr->next;
}
}
}
}
/*------------------------------------------------------------------------*/
int compute_pi_scaling_none(void)
{
int i;
SW_INS_PTR ptr;
double alpha_sum, psi0;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
alpha_sum = 0.0;
while (ptr != NULL) {
alpha_sum += ptr->inside_h;
ptr = ptr->next;
}
psi0 = digamma(alpha_sum);
ptr = occ_switches[i];
while (ptr != NULL) {
ptr->pi = exp(digamma(ptr->inside_h) - psi0);
ptr = ptr->next;
}
}
return BP_TRUE;
}
int compute_pi_scaling_log_exp(void)
{
int i;
SW_INS_PTR ptr;
double alpha_sum, psi0;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
alpha_sum = 0.0;
while (ptr != NULL) {
alpha_sum += ptr->inside_h;
ptr = ptr->next;
}
psi0 = digamma(alpha_sum);
ptr = occ_switches[i];
while (ptr != NULL) {
ptr->pi = digamma(ptr->inside_h) - psi0;
ptr = ptr->next;
}
}
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
int compute_inside_vb_scaling_none(void)
{
int i,k;
double sum,this_path_inside;
EG_NODE_PTR eg_ptr;
EG_PATH_PTR path_ptr;
for (i = 0; i < sorted_egraph_size; i++) {
eg_ptr = sorted_expl_graph[i];
sum = 0.0;
path_ptr = eg_ptr->path_ptr;
if (path_ptr == NULL) sum = 1.0;
while (path_ptr != NULL) {
this_path_inside = 1.0;
for (k = 0; k < path_ptr->children_len; k++) {
this_path_inside *= path_ptr->children[k]->inside;
}
for (k = 0; k < path_ptr->sws_len; k++) {
this_path_inside *= path_ptr->sws[k]->pi;
}
path_ptr->inside = this_path_inside;
sum += this_path_inside;
path_ptr = path_ptr->next;
}
eg_ptr->inside = sum;
}
return BP_TRUE;
}
int compute_inside_vb_scaling_log_exp(void)
{
int i,k,u;
double sum, this_path_inside, first_path_inside = 0.0, sum_rest;
EG_NODE_PTR eg_ptr;
EG_PATH_PTR path_ptr;
for (i = 0; i < sorted_egraph_size; i++) {
eg_ptr = sorted_expl_graph[i];
sum = 0.0;
path_ptr = eg_ptr->path_ptr;
if (path_ptr == NULL) {
sum = 0.0;
}
else {
sum_rest = 0.0;
u = 0;
while (path_ptr != NULL) {
this_path_inside = 0.0;
for (k = 0; k < path_ptr->children_len; k++) {
this_path_inside += path_ptr->children[k]->inside;
}
for (k = 0; k < path_ptr->sws_len; k++) {
this_path_inside += path_ptr->sws[k]->pi; /* log-scale */
}
path_ptr->inside = this_path_inside;
if (u == 0) {
first_path_inside = this_path_inside;
sum_rest += 1.0;
}
else if (this_path_inside - first_path_inside >= log(HUGE_PROB)) {
sum_rest *= exp(first_path_inside - this_path_inside);
first_path_inside = this_path_inside;
sum_rest += 1.0;
}
else {
sum_rest += exp(this_path_inside - first_path_inside);
}
path_ptr = path_ptr->next;
u++;
}
sum = first_path_inside + log(sum_rest);
}
eg_ptr->inside = sum;
}
return BP_TRUE;
}
int compute_daem_inside_vb_scaling_none(void)
{
int i,k;
double sum,this_path_inside;
EG_NODE_PTR eg_ptr;
EG_PATH_PTR path_ptr;
for (i = 0; i < sorted_egraph_size; i++) {
eg_ptr = sorted_expl_graph[i];
sum = 0.0;
path_ptr = eg_ptr->path_ptr;
if (path_ptr == NULL) sum = 1.0;
while (path_ptr != NULL) {
this_path_inside = 1.0;
for (k = 0; k < path_ptr->children_len; k++) {
this_path_inside *= path_ptr->children[k]->inside;
}
for (k = 0; k < path_ptr->sws_len; k++) {
this_path_inside *= pow(path_ptr->sws[k]->pi,itemp);
}
path_ptr->inside = this_path_inside;
sum += this_path_inside;
path_ptr = path_ptr->next;
}
eg_ptr->inside = sum;
}
return BP_TRUE;
}
int compute_daem_inside_vb_scaling_log_exp(void)
{
int i,k,u;
double sum, this_path_inside, first_path_inside = 0.0, sum_rest;
EG_NODE_PTR eg_ptr;
EG_PATH_PTR path_ptr;
for (i = 0; i < sorted_egraph_size; i++) {
eg_ptr = sorted_expl_graph[i];
sum = 0.0;
path_ptr = eg_ptr->path_ptr;
if (path_ptr == NULL) {
sum = 0.0;
}
else {
sum_rest = 0.0;
u = 0;
while (path_ptr != NULL) {
this_path_inside = 0.0;
for (k = 0; k < path_ptr->children_len; k++) {
this_path_inside += path_ptr->children[k]->inside;
}
for (k = 0; k < path_ptr->sws_len; k++) {
this_path_inside += itemp * path_ptr->sws[k]->pi;
}
path_ptr->inside = this_path_inside;
if (u == 0) {
first_path_inside = this_path_inside;
sum_rest += 1.0;
}
else if (this_path_inside - first_path_inside >= log(HUGE_PROB)) {
sum_rest *= exp(first_path_inside - this_path_inside);
first_path_inside = this_path_inside;
sum_rest += 1.0;
}
else {
sum_rest += exp(this_path_inside - first_path_inside);
}
path_ptr = path_ptr->next;
u++;
}
sum = first_path_inside + log(sum_rest);
}
eg_ptr->inside = sum;
}
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
/* [27 Aug 2007, by yuizumi]
* A variational free energy F is given by:
* F = F0 - F1 + L'
* where:
* F0 = compute_[daem_]free_energy_l0()
* F1 = compute_[daem_]free_energy_l1_scaling_{none|log_exp}()
* L' = compute_likelihood() / itemp
*/
double compute_free_energy_l0(void)
{
double l0 = 0.0;
double smooth_sum;
SW_INS_PTR ptr;
int i;
for (i = 0; i < occ_switch_tab_size; i++) {
smooth_sum = 0.0;
ptr = occ_switches[i];
while (ptr != NULL) {
smooth_sum += (ptr->smooth + 1.0);
ptr = ptr->next;
}
l0 += lngamma(smooth_sum);
smooth_sum = 0.0;
ptr = occ_switches[i];
while (ptr != NULL) {
smooth_sum += (ptr->inside_h);
ptr = ptr->next;
}
l0 -= lngamma(smooth_sum);
ptr = occ_switches[i];
while (ptr != NULL) {
l0 += lngamma(ptr->inside_h);
l0 -= lngamma(ptr->smooth + 1.0);
ptr = ptr->next;
}
}
return l0;
}
double compute_daem_free_energy_l0(void)
{
double l0 = 0.0;
double smooth_sum;
SW_INS_PTR ptr;
int i;
for (i = 0; i < occ_switch_tab_size; i++) {
smooth_sum = 0.0;
ptr = occ_switches[i];
while (ptr != NULL) {
smooth_sum += (ptr->smooth + 1.0);
ptr = ptr->next;
}
l0 += lngamma(smooth_sum);
smooth_sum = 0.0;
ptr = occ_switches[i];
while (ptr != NULL) {
smooth_sum += (ptr->inside_h);
ptr = ptr->next;
}
l0 -= lngamma(smooth_sum) / itemp;
ptr = occ_switches[i];
while (ptr != NULL) {
l0 += lngamma(ptr->inside_h) / itemp;
l0 -= lngamma(ptr->smooth + 1.0);
ptr = ptr->next;
}
}
return l0;
}
double compute_free_energy_l1_scaling_none(void)
{
double l1 = 0.0;
SW_INS_PTR ptr;
int i;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
while (ptr != NULL) {
l1 += ((ptr->inside_h - 1.0) - ptr->smooth) * log(ptr->pi);
ptr = ptr->next;
}
}
return l1;
}
double compute_free_energy_l1_scaling_log_exp(void)
{
double l1 = 0.0;
SW_INS_PTR ptr;
int i;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
while (ptr != NULL) {
/* pi is in log-scale */
l1 += (ptr->inside_h - (ptr->smooth + 1.0)) * ptr->pi;
ptr = ptr->next;
}
}
return l1;
}
double compute_daem_free_energy_l1_scaling_none(void)
{
double l1 = 0.0;
SW_INS_PTR ptr;
int i;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
while (ptr != NULL) {
l1 += ((ptr->inside_h - 1.0) / itemp - ptr->smooth) * log(ptr->pi);
ptr = ptr->next;
}
}
return l1;
}
double compute_daem_free_energy_l1_scaling_log_exp(void)
{
double l1 = 0.0;
SW_INS_PTR ptr;
int i;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
while (ptr != NULL) {
/* pi is in log-scale */
l1 += ((ptr->inside_h - 1.0) / itemp - ptr->smooth) * ptr->pi;
ptr = ptr->next;
}
}
return l1;
}
/*------------------------------------------------------------------------*/
int update_hyperparams(void)
{
int i;
SW_INS_PTR ptr;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
if (ptr->fixed_h > 0) continue;
while (ptr != NULL) {
ptr->inside_h = ptr->total_expect + ptr->smooth + 1.0;
ptr = ptr->next;
}
}
return BP_TRUE;
}
int update_daem_hyperparams(void)
{
int i;
SW_INS_PTR ptr;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
if (ptr->fixed_h > 0) continue;
while (ptr != NULL) {
ptr->inside_h = itemp * (ptr->total_expect + ptr->smooth) + 1.0;
ptr = ptr->next;
}
}
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
void save_hyperparams(void)
{
int i;
SW_INS_PTR ptr;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
if (ptr->fixed_h > 0) continue;
while (ptr != NULL) {
ptr->best_inside_h = ptr->inside_h;
ptr = ptr->next;
}
}
}
void restore_hyperparams(void)
{
int i;
SW_INS_PTR ptr;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
if (ptr->fixed_h > 0) continue;
while (ptr != NULL) {
ptr->inside_h = ptr->best_inside_h;
ptr = ptr->next;
}
}
}
void transfer_hyperparams(void)
{
int i;
SW_INS_PTR ptr;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
if (ptr->fixed_h > 0) continue;
while (ptr != NULL) {
ptr->smooth = ptr->inside_h - 1.0;
ptr = ptr->next;
}
}
}
/*------------------------------------------------------------------------*/
void get_param_means(void)
{
int i;
SW_INS_PTR ptr;
double sum;
for (i = 0; i < occ_switch_tab_size; i++) {
ptr = occ_switches[i];
if (ptr->fixed > 0) continue;
sum = 0.0;
while (ptr != NULL) {
sum += ptr->inside_h;
ptr = ptr->next;
}
ptr = occ_switches[i];
while (ptr != NULL) {
ptr->inside = ptr->inside_h / sum;
ptr = ptr->next;
}
}
}
/*------------------------------------------------------------------------*/

25
packages/prism/src/c/up/em_aux_vb.h Normal file
View File

@ -0,0 +1,25 @@
#ifndef EM_AUX_VB_H
#define EM_AUX_VB_H
int check_smooth_vb(void);
void initialize_hyperparams(void);
int compute_pi_scaling_none(void);
int compute_pi_scaling_log_exp(void);
int compute_inside_vb_scaling_none(void);
int compute_inside_vb_scaling_log_exp(void);
int compute_daem_inside_vb_scaling_none(void);
int compute_daem_inside_vb_scaling_log_exp(void);
double compute_free_energy_l0(void);
double compute_daem_free_energy_l0(void);
double compute_free_energy_l1_scaling_none(void);
double compute_free_energy_l1_scaling_log_exp(void);
double compute_daem_free_energy_l1_scaling_none(void);
double compute_daem_free_energy_l1_scaling_log_exp(void);
int update_hyperparams(void);
int update_daem_hyperparams(void);
void save_hyperparams(void);
void restore_hyperparams(void);
void transfer_hyperparams(void);
void get_param_means(void);
#endif /* EM_AUX_VB_H */

162
packages/prism/src/c/up/em_ml.c Normal file
View File

@ -0,0 +1,162 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "up/up.h"
#include "up/graph_aux.h"
#include "up/em.h"
#include "up/em_aux.h"
#include "up/em_aux_ml.h"
#include "up/flags.h"
#include "up/util.h"
/*------------------------------------------------------------------------*/
void config_em(EM_ENG_PTR em_ptr)
{
if (log_scale) {
em_ptr->compute_inside = daem ? compute_daem_inside_scaling_log_exp : compute_inside_scaling_log_exp;
em_ptr->examine_inside = examine_inside_scaling_log_exp;
em_ptr->compute_expectation = compute_expectation_scaling_log_exp;
em_ptr->compute_likelihood = compute_likelihood_scaling_log_exp;
em_ptr->compute_log_prior = daem ? compute_daem_log_prior : compute_log_prior;
em_ptr->update_params = em_ptr->smooth ? update_params_smooth : update_params;
}
else {
em_ptr->compute_inside = daem ? compute_daem_inside_scaling_none : compute_inside_scaling_none;
em_ptr->examine_inside = examine_inside_scaling_none;
em_ptr->compute_expectation = compute_expectation_scaling_none;
em_ptr->compute_likelihood = compute_likelihood_scaling_none;
em_ptr->compute_log_prior = daem ? compute_daem_log_prior : compute_log_prior;
em_ptr->update_params = em_ptr->smooth ? update_params_smooth : update_params;
}
}
/*------------------------------------------------------------------------*/
int run_em(EM_ENG_PTR em_ptr)
{
int r, iterate, old_valid, converged, saved = 0;
double likelihood, log_prior;
double lambda, old_lambda = 0.0;
config_em(em_ptr);
for (r = 0; r < num_restart; r++) {
SHOW_PROGRESS_HEAD("#em-iters", r);
initialize_params();
itemp = daem ? itemp_init : 1.0;
iterate = 0;
/* [21 Aug 2007, by yuizumi]
* while-loop for inversed temperature (DAEM). Note that this
* loop is evaluated only once for EM without annealing, since
* itemp initially set to 1.0 by the code above.
*/
while (1) {
if (daem) {
SHOW_PROGRESS_TEMP(itemp);
}
old_valid = 0;
while (1) {
if (CTRLC_PRESSED) {
SHOW_PROGRESS_INTR();
RET_ERR(err_ctrl_c_pressed);
}
RET_ON_ERR(em_ptr->compute_inside());
RET_ON_ERR(em_ptr->examine_inside());
likelihood = em_ptr->compute_likelihood();
log_prior = em_ptr->smooth ? em_ptr->compute_log_prior() : 0.0;
lambda = likelihood + log_prior;
if (verb_em) {
if (em_ptr->smooth) {
prism_printf("Iteration #%d:\tlog_likelihood=%.9f\tlog_prior=%.9f\tlog_post=%.9f\n", iterate, likelihood, log_prior, lambda);
}
else {
prism_printf("Iteration #%d:\tlog_likelihood=%.9f\n", iterate, likelihood);
}
}
if (debug_level) {
prism_printf("After I-step[%d]:\n", iterate);
prism_printf("likelihood = %.9f\n", likelihood);
print_egraph(debug_level, PRINT_EM);
}
if (!isfinite(lambda)) {
emit_internal_error("invalid log likelihood or log post: %s (at iteration #%d)",
isnan(lambda) ? "NaN" : "infinity", iterate);
RET_ERR(ierr_invalid_likelihood);
}
if (old_valid && old_lambda - lambda > prism_epsilon) {
emit_error("log likelihood or log post decreased [old: %.9f, new: %.9f] (at iteration #%d)",
old_lambda, lambda, iterate);
RET_ERR(err_invalid_likelihood);
}
if (itemp == 1.0 && likelihood > 0.0) {
emit_error("log likelihood greater than zero [value: %.9f] (at iteration #%d)",
likelihood, iterate);
RET_ERR(err_invalid_likelihood);
}
converged = (old_valid && lambda - old_lambda <= prism_epsilon);
if (converged || REACHED_MAX_ITERATE(iterate)) {
break;
}
old_lambda = lambda;
old_valid = 1;
RET_ON_ERR(em_ptr->compute_expectation());
if (debug_level) {
prism_printf("After O-step[%d]:\n", iterate);
print_egraph(debug_level, PRINT_EM);
}
SHOW_PROGRESS(iterate);
RET_ON_ERR(em_ptr->update_params());
iterate++;
}
/* [21 Aug 2007, by yuizumi]
* Note that 1.0 can be represented exactly in IEEE 754.
*/
if (itemp == 1.0) {
break;
}
itemp *= itemp_rate;
if (itemp >= 1.0) {
itemp = 1.0;
}
}
SHOW_PROGRESS_TAIL(converged, iterate, lambda);
if (r == 0 || lambda > em_ptr->lambda) {
em_ptr->lambda = lambda;
em_ptr->likelihood = likelihood;
em_ptr->iterate = iterate;
saved = (r < num_restart - 1);
if (saved) {
save_params();
}
}
}
if (saved) {
restore_params();
}
em_ptr->bic = compute_bic(em_ptr->likelihood);
em_ptr->cs = em_ptr->smooth ? compute_cs(em_ptr->likelihood) : 0.0;
return BP_TRUE;
}

8
packages/prism/src/c/up/em_ml.h Normal file
View File

@ -0,0 +1,8 @@
#ifndef EM_ML_H
#define EM_ML_H
void config_em(EM_ENG_PTR);
int run_em(EM_ENG_PTR);
#endif /* EM_ML_H */

181
packages/prism/src/c/up/em_preds.c Normal file
View File

@ -0,0 +1,181 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "up/up.h"
#include "up/graph.h"
#include "up/graph_aux.h"
#include "up/em.h"
#include "up/em_ml.h"
#include "up/em_vb.h"
#include "up/em_aux.h"
#include "up/em_aux_ml.h"
#include "up/em_aux_vb.h"
#include "up/viterbi.h"
#include "up/hindsight.h"
#include "up/flags.h"
#include "up/util.h"
/*------------------------------------------------------------------------*/
/* mic.c (B-Prolog) */
NORET myquit(int, const char *);
/*------------------------------------------------------------------------*/
int pc_prism_prepare_4(void)
{
TERM p_fact_list;
int size;
p_fact_list = bpx_get_call_arg(1,4);
size = bpx_get_integer(bpx_get_call_arg(2,4));
num_goals = bpx_get_integer(bpx_get_call_arg(3,4));
failure_root_index = bpx_get_integer(bpx_get_call_arg(4,4));
failure_observed = (failure_root_index != -1);
if (failure_root_index != -1) {
failure_subgoal_id = prism_goal_id_get(failure_atom);
if (failure_subgoal_id == -1) {
emit_internal_error("no subgoal ID allocated to `failure'");
RET_INTERNAL_ERR;
}
}
initialize_egraph_index();
alloc_sorted_egraph(size);
RET_ON_ERR(sort_egraphs(p_fact_list));
#ifndef MPI
if (verb_graph) {
print_egraph(0, PRINT_NEUTRAL);
}
#endif /* !(MPI) */
alloc_occ_switches();
if (fix_init_order) {
sort_occ_switches();
}
alloc_num_sw_vals();
return BP_TRUE;
}
int pc_prism_em_6(void)
{
struct EM_Engine em_eng;
RET_ON_ERR(check_smooth(&em_eng.smooth));
RET_ON_ERR(run_em(&em_eng));
release_num_sw_vals();
return
bpx_unify(bpx_get_call_arg(1,6), bpx_build_integer(em_eng.iterate )) &&
bpx_unify(bpx_get_call_arg(2,6), bpx_build_float (em_eng.lambda )) &&
bpx_unify(bpx_get_call_arg(3,6), bpx_build_float (em_eng.likelihood)) &&
bpx_unify(bpx_get_call_arg(4,6), bpx_build_float (em_eng.bic )) &&
bpx_unify(bpx_get_call_arg(5,6), bpx_build_float (em_eng.cs )) &&
bpx_unify(bpx_get_call_arg(6,6), bpx_build_integer(em_eng.smooth )) ;
}
int pc_prism_vbem_2(void)
{
struct VBEM_Engine vb_eng;
RET_ON_ERR(check_smooth_vb());
RET_ON_ERR(run_vbem(&vb_eng));
release_num_sw_vals();
return
bpx_unify(bpx_get_call_arg(1,2), bpx_build_integer(vb_eng.iterate)) &&
bpx_unify(bpx_get_call_arg(2,2), bpx_build_float(vb_eng.free_energy));
}
int pc_prism_both_em_2(void)
{
struct VBEM_Engine vb_eng;
RET_ON_ERR(check_smooth_vb());
RET_ON_ERR(run_vbem(&vb_eng));
get_param_means();
release_num_sw_vals();
return
bpx_unify(bpx_get_call_arg(1,2), bpx_build_integer(vb_eng.iterate)) &&
bpx_unify(bpx_get_call_arg(2,2), bpx_build_float(vb_eng.free_energy));
}
int pc_compute_inside_2(void)
{
int gid;
double prob;
EG_NODE_PTR eg_ptr;
gid = bpx_get_integer(bpx_get_call_arg(1,2));
initialize_egraph_index();
alloc_sorted_egraph(1);
RET_ON_ERR(sort_one_egraph(gid, 0, 1));
if (verb_graph) {
print_egraph(0, PRINT_NEUTRAL);
}
eg_ptr = expl_graph[gid];
if (log_scale) {
RET_ON_ERR(compute_inside_scaling_log_exp());
prob = eg_ptr->inside;
}
else {
RET_ON_ERR(compute_inside_scaling_none());
prob = eg_ptr->inside;
}
return bpx_unify(bpx_get_call_arg(2,2), bpx_build_float(prob));
}
/*------------------------------------------------------------------------*/
int pc_compute_probf_1(void)
{
EG_NODE_PTR eg_ptr;
int prmode;
prmode = bpx_get_integer(bpx_get_call_arg(1,1));
if (prmode == 3) {
compute_max();
return BP_TRUE;
}
eg_ptr = expl_graph[roots[0]->id];
failure_root_index = -1;
/* [31 Mar 2008, by yuizumi]
* compute_outside_scaling_*() is needed to be called because
* eg_ptr->outside computed by compute_expectation_scaling_*()
* is different from the outside probability.
*/
if (log_scale) {
RET_ON_ERR(compute_inside_scaling_log_exp());
if (prmode != 1) {
RET_ON_ERR(compute_expectation_scaling_log_exp());
RET_ON_ERR(compute_outside_scaling_log_exp());
}
}
else {
RET_ON_ERR(compute_inside_scaling_none());
if (prmode != 1) {
RET_ON_ERR(compute_expectation_scaling_none());
RET_ON_ERR(compute_outside_scaling_none());
}
}
return BP_TRUE;
}
/*------------------------------------------------------------------------*/

11
packages/prism/src/c/up/em_preds.h Normal file
View File

@ -0,0 +1,11 @@
#ifndef EM_PREDS_H
#define EM_PREDS_H
int pc_prism_prepare_4(void);
int pc_prism_em_6(void);
int pc_prism_vbem_2(void);
int pc_prism_both_em_7(void);
int pc_compute_inside_2(void);
int pc_compute_probf_1(void);
#endif /* EM_PREDS_H */

170
packages/prism/src/c/up/em_vb.c Normal file
View File

@ -0,0 +1,170 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "core/random.h"
#include "up/up.h"
#include "up/graph_aux.h"
#include "up/em.h"
#include "up/em_aux.h"
#include "up/em_aux_ml.h"
#include "up/em_aux_vb.h"
#include "up/flags.h"
#include "up/util.h"
/*------------------------------------------------------------------------*/
void config_vbem(VBEM_ENG_PTR vb_ptr)
{
if (log_scale) {
vb_ptr->compute_pi = compute_pi_scaling_log_exp;
vb_ptr->compute_inside = daem ? compute_daem_inside_vb_scaling_log_exp : compute_inside_vb_scaling_log_exp;
vb_ptr->examine_inside = examine_inside_scaling_log_exp;
vb_ptr->compute_expectation = compute_expectation_scaling_log_exp;
vb_ptr->compute_free_energy_l0 = daem ? compute_daem_free_energy_l0 : compute_free_energy_l0;
vb_ptr->compute_free_energy_l1 = daem ? compute_daem_free_energy_l1_scaling_log_exp : compute_free_energy_l1_scaling_log_exp;
vb_ptr->compute_likelihood = compute_likelihood_scaling_log_exp;
vb_ptr->update_hyperparams = daem ? update_daem_hyperparams : update_hyperparams;
}
else {
vb_ptr->compute_pi = compute_pi_scaling_none;
vb_ptr->compute_inside = daem ? compute_daem_inside_vb_scaling_none : compute_inside_vb_scaling_none;
vb_ptr->examine_inside = examine_inside_scaling_none;
vb_ptr->compute_expectation = compute_expectation_scaling_none;
vb_ptr->compute_free_energy_l0 = daem ? compute_daem_free_energy_l0 : compute_free_energy_l0;
vb_ptr->compute_free_energy_l1 = daem ? compute_daem_free_energy_l1_scaling_none : compute_free_energy_l1_scaling_none;
vb_ptr->compute_likelihood = compute_likelihood_scaling_none;
vb_ptr->update_hyperparams = daem ? update_daem_hyperparams : update_hyperparams;
}
}
/*------------------------------------------------------------------------*/
int run_vbem(VBEM_ENG_PTR vb_ptr)
{
int r, iterate, old_valid, converged, saved = 0;
double free_energy, old_free_energy = 0.0;
double l0, l1, l2;
config_vbem(vb_ptr);
for (r = 0; r < num_restart; r++) {
SHOW_PROGRESS_HEAD("#vbem-iters", r);
initialize_hyperparams();
itemp = daem ? itemp_init : 1.0;
iterate = 0;
/* [21 Aug 2007, by yuizumi]
* while-loop for inversed temperature (DAEM). Note that this
* loop is evaluated only once for EM without annealing, since
* itemp initially set to 1.0 by the code above.
*/
while (1) {
if (daem) {
SHOW_PROGRESS_TEMP(itemp);
}
old_valid = 0;
while (1) {
if (CTRLC_PRESSED) {
SHOW_PROGRESS_INTR();
RET_ERR(err_ctrl_c_pressed);
}
RET_ON_ERR(vb_ptr->compute_pi());
RET_ON_ERR(vb_ptr->compute_inside());
RET_ON_ERR(vb_ptr->examine_inside());
/* compute free_energy */
l0 = vb_ptr->compute_free_energy_l0();
l1 = vb_ptr->compute_free_energy_l1();
l2 = vb_ptr->compute_likelihood() / itemp; /* itemp == 1.0 for non-DAEM */
free_energy = l0 - l1 + l2;
if (verb_em) {
prism_printf("Iteration #%d:\tfree_energy=%.9f\n", iterate, free_energy);
}
if (debug_level) {
prism_printf("After I-step[%d]:\n", iterate);
prism_printf("free_energy = %.9f\n", free_energy);
print_egraph(debug_level, PRINT_VBEM);
}
if (!isfinite(free_energy)) {
emit_internal_error("invalid variational free energy: %s (at iteration #%d)",
isnan(free_energy) ? "NaN" : "infinity", iterate);
RET_ERR(err_invalid_free_energy);
}
if (old_valid && old_free_energy - free_energy > prism_epsilon) {
emit_error("variational free energy decreased [old: %.9f, new: %.9f] (at iteration #%d)",
old_free_energy, free_energy, iterate);
RET_ERR(err_invalid_free_energy);
}
if (itemp == 1.0 && free_energy > 0.0) {
emit_error("variational free energy exceeds zero [value: %.9f] (at iteration #%d)",
free_energy, iterate);
RET_ERR(err_invalid_free_energy);
}
converged = (old_valid && free_energy - old_free_energy <= prism_epsilon);
if (converged || REACHED_MAX_ITERATE(iterate)) {
break;
}
old_free_energy = free_energy;
old_valid = 1;
RET_ON_ERR(vb_ptr->compute_expectation());
if (debug_level) {
prism_printf("After O-step[%d]:\n", iterate);
print_egraph(debug_level, PRINT_VBEM);
}
SHOW_PROGRESS(iterate);
RET_ON_ERR(vb_ptr->update_hyperparams());
if (debug_level) {
prism_printf("After update[%d]:\n", iterate);
print_egraph(debug_level, PRINT_VBEM);
}
iterate++;
}
/* [21 Aug 2007, by yuizumi]
* Note that 1.0 can be represented exactly in IEEE 754.
*/
if (itemp == 1.0) {
break;
}
itemp *= itemp_rate;
if (itemp >= 1.0) {
itemp = 1.0;
}
}
SHOW_PROGRESS_TAIL(converged, iterate, free_energy);
if (r == 0 || free_energy > vb_ptr->free_energy) {
vb_ptr->free_energy = free_energy;
vb_ptr->iterate = iterate;
saved = (r < num_restart - 1);
if (saved) {
save_hyperparams();
}
}
}
if (saved) {
restore_hyperparams();
}
transfer_hyperparams();
return BP_TRUE;
}

8
packages/prism/src/c/up/em_vb.h Normal file
View File

@ -0,0 +1,8 @@
#ifndef EM_VB_H
#define EM_VB_H
void config_vbem(VBEM_ENG_PTR);
int run_vbem(VBEM_ENG_PTR);
#endif /* EM_VB_H */

158
packages/prism/src/c/up/flags.c Normal file
View File

@ -0,0 +1,158 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "up/up.h"
/*------------------------------------------------------------------------*/
/*
* Since these variables are initialized on start-up by the predicate
* reset_prism_flags/0, the initial values below are not actually used.
* The values are just for reference.
*
* Also, don't forget to modify mp_flags.c when adding new flags.
*/
int daem = 0;
int em_message = 1;
int em_progress = 10;
int error_on_cycle = 1;
int explicit_empty_expls = 1;
int fix_init_order = 1;
int init_method = 1;
double itemp_init = 0.1;
double itemp_rate = 1.2;
int log_scale = 0;
int max_iterate = -1; /* == DEFAULT_MAX_ITERATE */
int num_restart = 1;
double prism_epsilon = 0.0001;
int show_itemp = 0;
double std_ratio = 0.1;
int verb_em = 0;
int verb_graph = 0;
static int warn = 0;
/*
* This variable does not correspond to any prism flags, and hence is
* not initialized by reset_prism_flags/0.
*/
int debug_level = 0;
/*------------------------------------------------------------------------*/
int pc_set_daem_1(void)
{
daem = bpx_get_integer(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_em_message_1(void)
{
em_message = bpx_get_integer(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_em_progress_1(void)
{
em_progress = bpx_get_integer(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_error_on_cycle_1(void)
{
error_on_cycle = bpx_get_integer(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_explicit_empty_expls_1(void)
{
explicit_empty_expls = bpx_get_integer(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_fix_init_order_1(void)
{
fix_init_order = bpx_get_integer(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_init_method_1(void)
{
init_method = bpx_get_integer(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_itemp_init_1(void)
{
itemp_init = bpx_get_float(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_itemp_rate_1(void)
{
itemp_rate = bpx_get_float(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_log_scale_1(void)
{
log_scale = bpx_get_integer(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_max_iterate_1(void)
{
max_iterate = bpx_get_integer(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_num_restart_1(void)
{
num_restart = bpx_get_integer(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_prism_epsilon_1(void)
{
prism_epsilon = bpx_get_float(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_show_itemp_1(void)
{
show_itemp = bpx_get_integer(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_std_ratio_1(void)
{
std_ratio = bpx_get_float(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_verb_em_1(void)
{
verb_em = bpx_get_integer(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_verb_graph_1(void)
{
verb_graph = bpx_get_integer(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_warn_1(void)
{
warn = bpx_get_integer(bpx_get_call_arg(1,1));
return BP_TRUE;
}
int pc_set_debug_level_1(void)
{
debug_level = bpx_get_integer(bpx_get_call_arg(1,1));
return BP_TRUE;
}
/*------------------------------------------------------------------------*/

48
packages/prism/src/c/up/flags.h Normal file
View File

@ -0,0 +1,48 @@
#ifndef FLAGS_H
#define FLAGS_H
/*========================================================================*/
int pc_set_daem_1(void);
int pc_set_em_message_1(void);
int pc_set_em_progress_1(void);
int pc_set_error_on_cycle_1(void);
int pc_set_explicit_empty_expls_1(void);
int pc_set_fix_init_order_1(void);
int pc_set_init_method_1(void);
int pc_set_itemp_init_1(void);
int pc_set_itemp_rate_1(void);
int pc_set_log_scale_1(void);
int pc_set_max_iterate_1(void);
int pc_set_num_restart_1(void);
int pc_set_prism_epsilon_1(void);
int pc_set_show_itemp_1(void);
int pc_set_std_ratio_1(void);
int pc_set_verb_em_1(void);
int pc_set_verb_graph_1(void);
int pc_set_warn_1(void);
int pc_set_debug_level_1(void);
/*========================================================================*/
extern int daem;
extern int em_message;
extern int em_progress;
extern int error_on_cycle;
extern int explicit_empty_expls;
extern int fix_init_order;
extern int init_method;
extern double itemp_init;
extern double itemp_rate;
extern int log_scale;
extern int max_iterate;
extern int num_restart;
extern double prism_epsilon;
extern int show_itemp;
extern double std_ratio;
extern int verb_em;
extern int verb_graph;
extern int warn;
extern int debug_level;
#endif /* FLAGS_H */

888
packages/prism/src/c/up/graph.c Normal file
View File

@ -0,0 +1,888 @@
#include "up/up.h"
#include "up/flags.h"
#include "up/graph.h"
#include "up/util.h"
/*------------------------------------------------------------------------*/
/* mic.c (B-Prolog) */
NORET quit(const char *);
NORET myquit(int, const char *);
/* univ.c (B-Prolog) */
int list_length(BPLONG, BPLONG);
/*------------------------------------------------------------------------*/
static int max_egraph_size = INIT_MAX_EGRAPH_SIZE;
static int max_sorted_egraph_size = INIT_MAX_EGRAPH_SIZE;
static int egraph_size = 0;
static int max_sw_tab_size = INIT_MAX_SW_TABLE_SIZE;
static int max_sw_ins_tab_size = INIT_MAX_SW_INS_TABLE_SIZE;
static int index_to_sort = 0;
static int suppress_init_flags = 0; /* flag: suppress INIT_VISITED_FLAGS? */
int sorted_egraph_size = 0;
EG_NODE_PTR *expl_graph = NULL;
EG_NODE_PTR *sorted_expl_graph = NULL;
ROOT *roots = NULL;
int num_roots;
int num_goals;
int min_node_index;
int max_node_index;
SW_INS_PTR *switches = NULL;
SW_INS_PTR *switch_instances = NULL;
SW_INS_PTR *occ_switches = NULL; /* subset of switches */
int sw_tab_size = 0;
int sw_ins_tab_size = 0;
int occ_switch_tab_size = 0;
int failure_subgoal_id;
int failure_root_index;
/*------------------------------------------------------------------------*/
static void alloc_switch_table(void)
{
int i;
sw_tab_size = 0;
switches = (SW_INS_PTR *)MALLOC(max_sw_tab_size * sizeof(SW_INS_PTR));
for (i = 0; i < max_sw_tab_size; i++)
switches[i] = NULL;
}
static void expand_switch_table(int req_sw_tab_size)
{
int old_size,i;
if (req_sw_tab_size > max_sw_tab_size) {
old_size = max_sw_tab_size;
while (req_sw_tab_size > max_sw_tab_size)
max_sw_tab_size *= 2;
switches = (SW_INS_PTR *)REALLOC(switches,
max_sw_tab_size * sizeof(SW_INS_PTR));
for (i = old_size; i < max_sw_tab_size; i++)
switches[i] = NULL;
}
}
static void clean_switch_table(void)
{
if (switches != NULL) {
FREE(switches);
sw_tab_size = 0;
max_sw_tab_size = INIT_MAX_SW_TABLE_SIZE;
}
}
/*------------------------------------------------------------------------*/
static SW_INS_PTR alloc_switch_instance(void)
{
SW_INS_PTR sw_ptr = (SW_INS_PTR)MALLOC(sizeof(struct SwitchInstance));
sw_ptr->inside = 0.5;
return sw_ptr;
}
static void alloc_switch_instance_table(void)
{
int i;
sw_ins_tab_size = 0;
switch_instances =
(SW_INS_PTR *)MALLOC(max_sw_ins_tab_size * sizeof(SW_INS_PTR));
for (i = 0; i < max_sw_ins_tab_size; i++)
switch_instances[i] = NULL;
}
static void expand_switch_instance_table(int req_sw_ins_tab_size)
{
int old_size,i;
if (req_sw_ins_tab_size > max_sw_ins_tab_size) {
old_size = max_sw_ins_tab_size;
while (req_sw_ins_tab_size > max_sw_ins_tab_size)
max_sw_ins_tab_size *= 2;
switch_instances =
(SW_INS_PTR *)REALLOC(switch_instances,
max_sw_ins_tab_size * sizeof(SW_INS_PTR));
for (i = old_size; i < max_sw_ins_tab_size; i++)
switch_instances[i] = NULL;
}
}
static void clean_switch_instance_table(void)
{
int i;
if (switch_instances != NULL) {
for (i = 0; i < max_sw_ins_tab_size; i++)
FREE(switch_instances[i]);
FREE(switch_instances);
sw_ins_tab_size = 0;
max_sw_ins_tab_size = INIT_MAX_SW_INS_TABLE_SIZE;
}
}
/*------------------------------------------------------------------------*/
static EG_NODE_PTR alloc_egraph_node(void)
{
EG_NODE_PTR node_ptr = (EG_NODE_PTR)MALLOC(sizeof(struct ExplGraphNode));
node_ptr->inside = 1.0;
node_ptr->visited = 0;
node_ptr->path_ptr = NULL;
node_ptr->top_n = NULL;
node_ptr->top_n_len = 0;
node_ptr->shared = 0;
return node_ptr;
}
int pc_alloc_egraph_0(void)
{
int i;
alloc_switch_table();
alloc_switch_instance_table();
egraph_size = 0;
expl_graph = (EG_NODE_PTR *)MALLOC(max_egraph_size * sizeof(EG_NODE_PTR));
for (i = 0; i < max_egraph_size; i++) {
expl_graph[i] = alloc_egraph_node();
expl_graph[i]->id = i;
}
return BP_TRUE;
}
static void expand_egraph(int req_egraph_size)
{
int old_size,i;
if (req_egraph_size > max_egraph_size) {
old_size = max_egraph_size;
while (req_egraph_size > max_egraph_size) {
if (max_egraph_size > MAX_EGRAPH_SIZE_EXPAND_LIMIT) {
max_egraph_size += MAX_EGRAPH_SIZE_EXPAND_LIMIT;
}
else {
max_egraph_size *= 2;
}
}
expl_graph =
(EG_NODE_PTR *)REALLOC(expl_graph,
max_egraph_size * sizeof(EG_NODE_PTR));
for (i = old_size; i < max_egraph_size; i++) {
expl_graph[i] = alloc_egraph_node();
expl_graph[i]->id = i;
}
}
}
static void clean_sorted_egraph(void)
{
FREE(sorted_expl_graph);
}
/* Clean-up the base support graphs and switches */
static void clean_base_egraph(void)
{
int i,j;
EG_PATH_PTR path_ptr,next_path_ptr;
clean_switch_table();
clean_switch_instance_table();
if (expl_graph != NULL) {
for (i = 0; i < max_egraph_size; i++) {
if (expl_graph[i] == NULL) continue;
path_ptr = expl_graph[i]->path_ptr;
while (path_ptr != NULL) {
FREE(path_ptr->children);
FREE(path_ptr->sws);
next_path_ptr = path_ptr->next;
FREE(path_ptr);
path_ptr = next_path_ptr;
}
if (expl_graph[i]->top_n != NULL) {
for (j = 0; j < expl_graph[i]->top_n_len; j++) {
FREE(expl_graph[i]->top_n[j]->top_n_index);
FREE(expl_graph[i]->top_n[j]);
}
FREE(expl_graph[i]->top_n);
}
FREE(expl_graph[i]);
}
FREE(expl_graph);
egraph_size = 0;
max_egraph_size = INIT_MAX_EGRAPH_SIZE;
INIT_MIN_MAX_NODE_NOS;
}
}
int pc_clean_base_egraph_0(void)
{
clean_base_egraph();
return BP_TRUE;
}
int pc_clean_egraph_0(void)
{
clean_sorted_egraph();
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
int pc_export_switch_2(void)
{
BPLONG sw,sw_ins_ids,sw_ins_id;
SW_INS_PTR *curr_ins_ptr;
sw = bpx_get_integer(bpx_get_call_arg(1,2));
sw_ins_ids = bpx_get_call_arg(2,2);
if (sw >= max_sw_tab_size) expand_switch_table(sw + 1);
if (sw >= sw_tab_size) sw_tab_size = sw + 1;
curr_ins_ptr = &switches[sw];
while (bpx_is_list(sw_ins_ids)) {
sw_ins_id = bpx_get_integer(bpx_get_car(sw_ins_ids));
sw_ins_ids = bpx_get_cdr(sw_ins_ids);
if (sw_ins_id >= max_sw_ins_tab_size)
expand_switch_instance_table(sw_ins_id + 1);
if (sw_ins_id >= sw_ins_tab_size) sw_ins_tab_size = sw_ins_id + 1;
switch_instances[sw_ins_id] = alloc_switch_instance();
switch_instances[sw_ins_id]->id = sw_ins_id;
*curr_ins_ptr = switch_instances[sw_ins_id];
curr_ins_ptr = &switch_instances[sw_ins_id]->next;
}
*curr_ins_ptr = NULL;
return BP_TRUE;
}
static int add_egraph_path(int node_id, TERM children_prolog, TERM sws_prolog)
{
EG_PATH_PTR path_ptr;
EG_NODE_PTR *children;
SW_INS_PTR *sws;
int len,k;
int child,sw;
TERM p_child,p_sw;
int list_length(BPLONG, BPLONG);
if (node_id >= max_egraph_size) expand_egraph(node_id + 1);
if (node_id >= egraph_size) egraph_size = node_id + 1;
path_ptr = (EG_PATH_PTR)MALLOC(sizeof(struct ExplGraphPath));
len = list_length(children_prolog, children_prolog);
if (len > 0) {
path_ptr->children_len = len;
children = (EG_NODE_PTR *)MALLOC(sizeof(EG_NODE_PTR) * len);
k = 0;
while (bpx_is_list(children_prolog)) {
p_child = bpx_get_car(children_prolog);
if (!bpx_is_integer(p_child))
RET_ERR(err_invalid_goal_id);
child = bpx_get_integer(p_child);
children[k] = expl_graph[child];
k++;
children_prolog = bpx_get_cdr(children_prolog);
}
path_ptr->children = children;
}
else {
path_ptr->children_len = 0;
path_ptr->children = NULL;
}
len = list_length(sws_prolog, sws_prolog);
if (len > 0) {
path_ptr->sws_len = len;
sws = (SW_INS_PTR *)MALLOC(sizeof(SW_INS_PTR) * len);
k = 0;
while (bpx_is_list(sws_prolog)) {
p_sw = bpx_get_car(sws_prolog);
if (!bpx_is_integer(p_sw))
RET_ERR(err_invalid_switch_instance_id);
sw = bpx_get_integer(p_sw);
sws[k] = switch_instances[sw];
k++;
sws_prolog = bpx_get_cdr(sws_prolog);
}
path_ptr->sws = sws;
}
else {
path_ptr->sws_len = 0;
path_ptr->sws = NULL;
}
path_ptr->next = expl_graph[node_id]->path_ptr;
expl_graph[node_id]->path_ptr = path_ptr;
return BP_TRUE;
}
int pc_add_egraph_path_3(void)
{
TERM p_node_id,p_children,p_sws;
int node_id;
/* children_prolog and sws_prolog must be in the table area */
p_node_id = bpx_get_call_arg(1,3);
p_children = bpx_get_call_arg(2,3);
p_sws = bpx_get_call_arg(3,3);
if (!bpx_is_integer(p_node_id)) RET_ERR(err_invalid_goal_id);
node_id = bpx_get_integer(p_node_id);
XDEREF(p_children);
XDEREF(p_sws);
RET_ON_ERR(add_egraph_path(node_id,p_children,p_sws));
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
void alloc_sorted_egraph(int n)
{
int i;
max_sorted_egraph_size = INIT_MAX_EGRAPH_SIZE;
sorted_expl_graph =
(EG_NODE_PTR *)MALLOC(sizeof(EG_NODE_PTR) * max_sorted_egraph_size);
roots = (ROOT *)MALLOC(sizeof(ROOT *) * n);
for (i = 0; i < n; i++)
roots[i] = NULL;
num_roots = n;
}
static void expand_sorted_egraph(int req_sorted_egraph_size)
{
if (req_sorted_egraph_size > max_sorted_egraph_size) {
while (req_sorted_egraph_size > max_sorted_egraph_size) {
if (max_sorted_egraph_size > MAX_EGRAPH_SIZE_EXPAND_LIMIT)
max_sorted_egraph_size += MAX_EGRAPH_SIZE_EXPAND_LIMIT;
else
max_sorted_egraph_size *= 2;
}
sorted_expl_graph =
(EG_NODE_PTR *)
REALLOC(sorted_expl_graph,
max_sorted_egraph_size * sizeof(EG_NODE_PTR));
}
}
/*------------------------------------------------------------------------*/
void initialize_egraph_index(void)
{
index_to_sort = 0;
}
static int topological_sort(int node_id)
{
EG_PATH_PTR path_ptr;
EG_NODE_PTR *children;
int k,len;
EG_NODE_PTR child_ptr;
expl_graph[node_id]->visited = 2;
UPDATE_MIN_MAX_NODE_NOS(node_id);
path_ptr = expl_graph[node_id]->path_ptr;
while (path_ptr != NULL) {
children = path_ptr->children;
len = path_ptr->children_len;
for (k = 0; k < len; k++) {
child_ptr = children[k];
if (child_ptr->visited == 2 && error_on_cycle)
RET_ERR(err_cycle_detected);
if (child_ptr->visited == 0) {
RET_ON_ERR(topological_sort(child_ptr->id));
expand_sorted_egraph(index_to_sort + 1);
sorted_expl_graph[index_to_sort++] = child_ptr;
}
child_ptr->shared += 1;
}
path_ptr = path_ptr->next;
}
expl_graph[node_id]->visited = 1;
return BP_TRUE;
}
int sort_one_egraph(int root_id, int root_index, int count)
{
roots[root_index] = (ROOT)MALLOC(sizeof(struct ObservedFactNode));
roots[root_index]->id = root_id;
roots[root_index]->count = count;
if (expl_graph[root_id]->visited == 1) {
/*
* This top-goal is also a sub-goal of another top-goal. This
* should occur only when INIT_VISITED_FLAGS is suppressed
* (i.e. we have more than one observed goal in learning).
*/
if (suppress_init_flags) return BP_TRUE;
}
if (expl_graph[root_id]->visited != 0) RET_INTERNAL_ERR;
RET_ON_ERR(topological_sort(root_id));
expand_sorted_egraph(index_to_sort + 1);
sorted_expl_graph[index_to_sort] = expl_graph[root_id];
index_to_sort++;
sorted_egraph_size = index_to_sort;
/* initialize flags after use */
if (!suppress_init_flags) INIT_VISITED_FLAGS;
return BP_TRUE;
}
int sort_egraphs(TERM p_fact_list) /* assumed to be dereferenced in advance */
{
TERM pair;
int root_index = 0, goal_id, count;
sorted_egraph_size = 0;
suppress_init_flags = 1;
while (bpx_is_list(p_fact_list)) {
pair = bpx_get_car(p_fact_list);
p_fact_list = bpx_get_cdr(p_fact_list);
goal_id = bpx_get_integer(bpx_get_arg(1,pair));
count = bpx_get_integer(bpx_get_arg(2,pair));
if (sort_one_egraph(goal_id,root_index,count) == BP_ERROR) {
INIT_VISITED_FLAGS;
return BP_ERROR;
}
root_index++;
}
suppress_init_flags = 0;
INIT_VISITED_FLAGS;
return BP_TRUE;
}
/*
* Sort the explanation graph such that no node sorted_expl_graph[i] calls
* node sorted_expl_graph[j] if i < j.
*
* This function is used only for probf/1-2, so we don't have to consider
* about scaling here.
*/
int pc_alloc_sort_egraph_1(void)
{
int root_id;
root_id = bpx_get_integer(bpx_get_call_arg(1,1));
index_to_sort = 0;
alloc_sorted_egraph(1);
RET_ON_ERR(sort_one_egraph(root_id,0,1));
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
static void clean_root_tables(void)
{
int i;
if (roots != NULL) {
for (i = 0; i < num_roots; i++)
FREE(roots[i]);
FREE(roots);
}
}
int pc_clean_external_tables_0(void)
{
clean_root_tables();
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
/*
* Export probabilities of switches from Prolog to C. Switches is
* a list of switches, each of which takes the form:
*
* sw(Id,InstanceIds,Probs,SmoothCs,Fixed,FixedH),
*
* where
* Id: identifier of the switch
* InstanceIds: list of ids of the instances of the switch
* Probs: current probabilities assigned to the instance switches
* SmoothCs: current pseudo counts assigned to the instance switches
* Fixed: probabilities fixed?
* FixedH: pseudo counts fixed?
*
* The structures for switch instances have been allocated. This
* function only fills out the initial probabilities.
*/
int pc_export_sw_info_1(void)
{
int sw_id,instance_id,fixed,fixed_h;
double prob,smooth;
TERM p_switches, p_switch;
TERM p_instance_list,p_prob_list,p_smooth_list;
TERM p_prob,p_smooth;
p_switches = bpx_get_call_arg(1,1);
while (bpx_is_list(p_switches)) {
/* p_switch: sw(Id,InstList,ProbList,SmoothCList,FixedP,FixedH) */
p_switch = bpx_get_car(p_switches);
sw_id = bpx_get_integer(bpx_get_arg(1,p_switch));
p_instance_list = bpx_get_arg(2,p_switch);
p_prob_list = bpx_get_arg(3,p_switch);
p_smooth_list = bpx_get_arg(4,p_switch);
fixed = bpx_get_integer(bpx_get_arg(5,p_switch));
fixed_h = bpx_get_integer(bpx_get_arg(6,p_switch));
while (bpx_is_list(p_instance_list)) {
instance_id = bpx_get_integer(bpx_get_car(p_instance_list));
p_prob = bpx_get_car(p_prob_list);
p_smooth = bpx_get_car(p_smooth_list);
if (bpx_is_integer(p_prob)) {
prob = (double)bpx_get_integer(p_prob);
}
else if (bpx_is_float(p_prob)) {
prob = bpx_get_float(p_prob);
}
else {
RET_ERR(illegal_arguments);
}
if (bpx_is_integer(p_smooth)) {
smooth = (double)bpx_get_integer(p_smooth);
}
else if (bpx_is_float(p_smooth)) {
smooth = bpx_get_float(p_smooth);
}
else {
RET_ERR(illegal_arguments);
}
switch_instances[instance_id]->inside = prob;
switch_instances[instance_id]->fixed = fixed;
switch_instances[instance_id]->fixed_h = fixed_h;
switch_instances[instance_id]->smooth_prolog = smooth;
p_instance_list = bpx_get_cdr(p_instance_list);
p_prob_list = bpx_get_cdr(p_prob_list);
p_smooth_list = bpx_get_cdr(p_smooth_list);
}
p_switches = bpx_get_cdr(p_switches);
}
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
/* the following functions are needed by probf */
int pc_import_sorted_graph_size_1(void)
{
return bpx_unify(bpx_get_call_arg(1,1),
bpx_build_integer(sorted_egraph_size));
}
int pc_import_sorted_graph_gid_2(void)
{
int idx = bpx_get_integer(bpx_get_call_arg(1,2));
return bpx_unify(bpx_get_call_arg(2,2),
bpx_build_integer(sorted_expl_graph[idx]->id));
}
int pc_import_sorted_graph_paths_2(void)
{
TERM paths0,paths1,glist,slist,t0,t1,p_tmp;
EG_PATH_PTR path_ptr;
EG_NODE_PTR *children;
SW_INS_PTR *sws;
int node_id,k,len;
node_id = bpx_get_integer(bpx_get_call_arg(1,2));
path_ptr = sorted_expl_graph[node_id]->path_ptr;
if (path_ptr == NULL) {
if (explicit_empty_expls) {
t0 = bpx_build_list();
t1 = bpx_build_list();
bpx_unify(bpx_get_car(t0),bpx_build_nil());
bpx_unify(bpx_get_cdr(t0),t1);
bpx_unify(bpx_get_car(t1),bpx_build_nil());
bpx_unify(bpx_get_cdr(t1),bpx_build_nil());
paths0 = bpx_build_list();
bpx_unify(bpx_get_car(paths0),t0);
bpx_unify(bpx_get_cdr(paths0),bpx_build_nil());
}
else paths0 = bpx_build_nil();
}
else {
paths0 = bpx_build_nil();
while (path_ptr != NULL) {
len = path_ptr->children_len;
children = path_ptr->children;
if (len > 0) {
glist = bpx_build_list();
p_tmp = glist;
for (k = 0; k < len; k++) {
bpx_unify(bpx_get_car(p_tmp),
bpx_build_integer(children[k]->id));
if (k == len - 1) {
bpx_unify(bpx_get_cdr(p_tmp),bpx_build_nil());
}
else {
bpx_unify(bpx_get_cdr(p_tmp),bpx_build_list());
p_tmp = bpx_get_cdr(p_tmp);
}
}
}
else glist = bpx_build_nil();
len = path_ptr->sws_len;
sws = path_ptr->sws;
if (len > 0) {
slist = bpx_build_list();
p_tmp = slist;
for (k = 0; k < len; k++) {
bpx_unify(bpx_get_car(p_tmp),bpx_build_integer(sws[k]->id));
if (k == len - 1) {
bpx_unify(bpx_get_cdr(p_tmp),bpx_build_nil());
}
else {
bpx_unify(bpx_get_cdr(p_tmp),bpx_build_list());
p_tmp = bpx_get_cdr(p_tmp);
}
}
}
else slist = bpx_build_nil();
if (explicit_empty_expls ||
!bpx_is_nil(glist) || !bpx_is_nil(slist)) {
t0 = bpx_build_list();
t1 = bpx_build_list();
bpx_unify(bpx_get_car(t0),glist);
bpx_unify(bpx_get_cdr(t0),t1);
bpx_unify(bpx_get_car(t1),slist);
bpx_unify(bpx_get_cdr(t1),bpx_build_nil());
paths1 = bpx_build_list();
bpx_unify(bpx_get_car(paths1),t0);
bpx_unify(bpx_get_cdr(paths1),paths0);
paths0 = paths1;
}
path_ptr = path_ptr->next;
}
}
return bpx_unify(bpx_get_call_arg(2,2),paths0);
}
int pc_get_gnode_inside_2(void)
{
int idx = bpx_get_integer(bpx_get_call_arg(1,2));
return bpx_unify(bpx_get_call_arg(2,2),
bpx_build_float(expl_graph[idx]->inside));
}
int pc_get_gnode_outside_2(void)
{
int idx = bpx_get_integer(bpx_get_call_arg(1,2));
return bpx_unify(bpx_get_call_arg(2,2),
bpx_build_float(expl_graph[idx]->outside));
}
int pc_get_gnode_viterbi_2(void)
{
int idx = bpx_get_integer(bpx_get_call_arg(1,2));
return bpx_unify(bpx_get_call_arg(2,2),
bpx_build_float(expl_graph[idx]->max));
}
int pc_get_snode_inside_2(void)
{
int idx = bpx_get_integer(bpx_get_call_arg(1,2));
double val = switch_instances[idx]->inside;
if (log_scale) val = log(val);
return bpx_unify(bpx_get_call_arg(2,2),bpx_build_float(val));
}
int pc_get_snode_expectation_2(void)
{
int idx = bpx_get_integer(bpx_get_call_arg(1,2));
return bpx_unify(bpx_get_call_arg(2,2),
bpx_build_float(switch_instances[idx]->total_expect));
}
int pc_import_occ_switches_3(void)
{
TERM p_sw_list,p_sw_list0,p_sw_list1;
TERM p_sw_ins_list0,p_sw_ins_list1,sw,sw_ins;
TERM p_num_sw, p_num_sw_ins;
int i;
int num_sw_ins;
void release_occ_switches();
#ifdef __YAP_PROLOG__
TERM *hstart;
restart:
hstart = heap_top;
#endif
p_sw_list = bpx_get_call_arg(1,3);
p_num_sw = bpx_get_call_arg(2,3);
p_num_sw_ins = bpx_get_call_arg(3,3);
p_sw_list0 = bpx_build_nil();
num_sw_ins = 0;
for (i = 0; i < occ_switch_tab_size; i++) {
SW_INS_PTR ptr;
#ifdef __YAP_PROLOG__
if ( heap_top + 64*1024 >= local_top ) {
H = hstart;
/* running out of stack */
extern int Yap_gcl(UInt gc_lim, Int predarity, CELL *current_env, yamop *nextop);
Yap_gcl(4*64*1024, 3, ENV, P);
goto restart;
}
#endif
sw = bpx_build_structure("sw",2);
bpx_unify(bpx_get_arg(1,sw), bpx_build_integer(i));
p_sw_ins_list0 = bpx_build_nil();
ptr = occ_switches[i];
while (ptr != NULL) {
num_sw_ins++;
if (ptr->inside <= 0.0) ptr->inside = 0.0; /* FIXME: quick hack */
sw_ins = bpx_build_structure("sw_ins",4);
bpx_unify(bpx_get_arg(1,sw_ins),bpx_build_integer(ptr->id));
bpx_unify(bpx_get_arg(2,sw_ins),bpx_build_float(ptr->inside));
bpx_unify(bpx_get_arg(3,sw_ins),bpx_build_float(ptr->smooth));
bpx_unify(bpx_get_arg(4,sw_ins),bpx_build_float(ptr->total_expect));
p_sw_ins_list1 = bpx_build_list();
bpx_unify(bpx_get_car(p_sw_ins_list1),sw_ins);
bpx_unify(bpx_get_cdr(p_sw_ins_list1),p_sw_ins_list0);
p_sw_ins_list0 = p_sw_ins_list1;
ptr = ptr->next;
}
bpx_unify(bpx_get_arg(2,sw),p_sw_ins_list0);
p_sw_list1 = bpx_build_list();
bpx_unify(bpx_get_car(p_sw_list1),sw);
bpx_unify(bpx_get_cdr(p_sw_list1),p_sw_list0);
p_sw_list0 = p_sw_list1;
}
release_occ_switches();
return
bpx_unify(p_sw_list, p_sw_list0) &&
bpx_unify(p_num_sw, bpx_build_integer(occ_switch_tab_size)) &&
bpx_unify(p_num_sw_ins, bpx_build_integer(num_sw_ins));
}
/*------------------------------------------------------------------------*/
void graph_stats(int stats[4])
{
int num_goal_nodes = 0;
int num_switch_nodes = 0;
int total_shared = 0;
int i;
EG_NODE_PTR eg_ptr;
EG_PATH_PTR path_ptr;
for (i = 0; i < sorted_egraph_size; i++) {
eg_ptr = sorted_expl_graph[i];
total_shared += eg_ptr->shared;
path_ptr = eg_ptr->path_ptr;
while (path_ptr != NULL) {
num_goal_nodes += path_ptr->children_len;
num_switch_nodes += path_ptr->sws_len;
path_ptr = path_ptr->next;
}
}
stats[0] = sorted_egraph_size;
stats[1] = num_goal_nodes;
stats[2] = num_switch_nodes;
stats[3] = total_shared;
}
int pc_import_graph_stats_4(void)
{
int stats[4];
double avg_shared;
graph_stats(stats);
avg_shared = (double)(stats[3]) / stats[0];
return
bpx_unify(bpx_get_call_arg(1,4), bpx_build_integer(stats[0])) &&
bpx_unify(bpx_get_call_arg(2,4), bpx_build_integer(stats[1])) &&
bpx_unify(bpx_get_call_arg(3,4), bpx_build_integer(stats[2])) &&
bpx_unify(bpx_get_call_arg(4,4), bpx_build_float(avg_shared));
}

82
packages/prism/src/c/up/graph.h Normal file
View File

@ -0,0 +1,82 @@
#ifndef GRAPH_H
#define GRAPH_H
/*====================================================================*/
#define INIT_MAX_SW_TABLE_SIZE 16
#define INIT_MAX_SW_INS_TABLE_SIZE 64
#define INIT_MAX_EGRAPH_SIZE (1 << 8)
#define MAX_EGRAPH_SIZE_EXPAND_LIMIT (128 << 10)
/* node_id should be non-negative */
#define UPDATE_MIN_MAX_NODE_NOS(node_id) do { \
if (min_node_index < 0 || node_id < min_node_index) \
min_node_index = node_id; \
if (node_id > max_node_index) \
max_node_index = node_id; \
} while (0)
#define INIT_MIN_MAX_NODE_NOS do { \
min_node_index = -1; \
max_node_index = -1; \
} while (0)
#define INIT_VISITED_FLAGS do { \
int i; \
for (i = min_node_index; i <= max_node_index; i++) \
expl_graph[i]->visited = 0; \
} while (0)
/*====================================================================*/
int pc_alloc_egraph_0(void);
int pc_clean_base_egraph_0(void);
int pc_clean_egraph_0(void);
int pc_export_switch_2(void);
int pc_add_egraph_path_3(void);
int pc_alloc_sort_egraph_1(void);
int pc_clean_external_tables_0(void);
int pc_export_sw_info_1(void);
int pc_import_sorted_graph_size_1(void);
int pc_import_sorted_graph_gid_2(void);
int pc_import_sorted_graph_paths_2(void);
int pc_get_gnode_inside_2(void);
int pc_get_gnode_outside_2(void);
int pc_get_gnode_viterbi_2(void);
int pc_get_snode_inside_2(void);
int pc_get_snode_expectation_2(void);
int pc_import_occ_switches_3(void);
void graph_stats(int[4]);
/*--------------------------------------------------------------------*/
void alloc_sorted_egraph(int);
void initialize_egraph_index(void);
int sort_one_egraph(int, int, int);
int sort_egraphs(TERM);
/*====================================================================*/
extern int sorted_egraph_size;
extern EG_NODE_PTR *expl_graph;
extern EG_NODE_PTR *sorted_expl_graph;
extern int num_roots;
extern int num_goals;
extern ROOT *roots;
extern int min_node_index;
extern int max_node_index;
extern int sw_tab_size;
extern int sw_ins_tab_size;
extern int occ_switch_tab_size;
extern SW_INS_PTR *switches;
extern SW_INS_PTR *switch_instances;
extern SW_INS_PTR *occ_switches;
extern int failure_subgoal_id;
extern int failure_root_index;
/*====================================================================*/
#endif /* GRAPH_H */

299
packages/prism/src/c/up/graph_aux.c Normal file
View File

@ -0,0 +1,299 @@
#include <stdlib.h>
#include "bprolog.h"
#include "up/up.h"
#include "up/graph.h"
#include "up/graph_aux.h"
#include "up/flags.h"
/*------------------------------------------------------------------------*/
/* mic.c (B-Prolog) */
void quit(const char *);
/*------------------------------------------------------------------------*/
static EG_NODE_PTR *subgraph;
static int subgraph_size;
static int max_subgraph_size;
/*------------------------------------------------------------------------*/
static void alloc_subgraph(void)
{
max_subgraph_size = INIT_MAX_EGRAPH_SIZE;
subgraph = (EG_NODE_PTR *)MALLOC(sizeof(EG_NODE_PTR) * max_subgraph_size);
}
static void expand_subgraph(int req_subgraph_size)
{
if (req_subgraph_size > max_subgraph_size) {
while (req_subgraph_size > max_subgraph_size) {
if (max_subgraph_size > MAX_EGRAPH_SIZE_EXPAND_LIMIT)
max_subgraph_size += MAX_EGRAPH_SIZE_EXPAND_LIMIT;
else
max_subgraph_size *= 2;
}
subgraph = REALLOC(subgraph, sizeof(EG_NODE_PTR) * max_subgraph_size);
}
}
static void release_subgraph(void)
{
free(subgraph);
subgraph = NULL;
}
static void traverse_egraph(EG_NODE_PTR node_ptr)
{
int i;
EG_NODE_PTR c_node_ptr;
EG_PATH_PTR path_ptr;
node_ptr->visited = 1;
path_ptr = node_ptr->path_ptr;
while (path_ptr != NULL) {
for (i = 0; i < path_ptr->children_len; i++) {
c_node_ptr = path_ptr->children[i];
if (c_node_ptr->visited != 1) {
if (c_node_ptr->visited == 0) {
traverse_egraph(c_node_ptr);
}
expand_subgraph(subgraph_size + 1);
subgraph[subgraph_size] = c_node_ptr;
subgraph_size++;
}
}
path_ptr = path_ptr->next;
}
}
/*------------------------------------------------------------------------*/
/* `mode' is a macro prefixed by `PRINT_' */
void print_egraph(int level, int mode)
{
ROOT root_ptr;
EG_NODE_PTR eg_ptr, node_ptr;
EG_PATH_PTR path_ptr;
SW_INS_PTR sw_ptr;
int log_scale1;
int r,u,e,i,k,len;
/* disable scaling for non-learning */
log_scale1 = (mode > 0) ? log_scale : 0;
alloc_subgraph();
for (r = 0; r < num_roots; r++) {
root_ptr = roots[r];
if (level >= 1) {
fprintf(curr_out," <<Goal[%d]: %s (id=%d, count=%d)>>\n",
r,prism_goal_string(root_ptr->id),
root_ptr->id,root_ptr->count);
}
else {
fprintf(curr_out," <<Goal[%d]: (count=%d)>>\n",r,root_ptr->count);
}
subgraph_size = 0;
traverse_egraph(expl_graph[root_ptr->id]);
expand_subgraph(subgraph_size + 1);
subgraph[subgraph_size] = expl_graph[root_ptr->id];
for (i = subgraph_size; i >= 0; i--) {
eg_ptr = subgraph[i];
if (eg_ptr->visited == 2) {
fprintf(curr_out," g[%d]:%s\n",
eg_ptr->id,prism_goal_string(eg_ptr->id));
fprintf(curr_out," **** already shown ****\n");
continue;
}
eg_ptr->visited = 2;
if (level == 0) {
fprintf(curr_out," g[%d]:%s\n",
eg_ptr->id,prism_goal_string(eg_ptr->id));
}
if (level >= 3) {
fprintf(curr_out," g[%d]:%s.addr = <%p>\n",
eg_ptr->id,prism_goal_string(eg_ptr->id),eg_ptr);
}
if (level >= 1) {
if (log_scale1) {
fprintf(curr_out," g[%d]:%s.inside = %.9e (%.9e)\n",
eg_ptr->id,prism_goal_string(eg_ptr->id),
eg_ptr->inside,exp(eg_ptr->inside));
fprintf(curr_out," g[%d]:%s.outside = %.9e (%.9e)\n",
eg_ptr->id,prism_goal_string(eg_ptr->id),
eg_ptr->outside,exp(eg_ptr->outside));
fprintf(curr_out," g[%d]:%s.first_outside = %.9e (%.9e)\n",
eg_ptr->id,prism_goal_string(eg_ptr->id),
eg_ptr->first_outside,exp(eg_ptr->first_outside));
}
else {
fprintf(curr_out," g[%d]:%s.inside = %.9e\n",
eg_ptr->id,prism_goal_string(eg_ptr->id),
eg_ptr->inside);
fprintf(curr_out," g[%d]:%s.outside = %.9e\n",
eg_ptr->id,prism_goal_string(eg_ptr->id),
eg_ptr->outside);
}
if (mode == PRINT_VITERBI) {
fprintf(curr_out," g[%d]:%s.max = %.9e\n",
eg_ptr->id,prism_goal_string(eg_ptr->id),
eg_ptr->max);
fprintf(curr_out," g[%d]:%s.top_n_len = %d\n",
eg_ptr->id,prism_goal_string(eg_ptr->id),
eg_ptr->top_n_len);
if (eg_ptr->top_n != NULL) {
for (e = 0; e < eg_ptr->top_n_len; e++) {
if (eg_ptr->top_n[e] == NULL) continue;
fprintf(curr_out," top_n[%d]->goal_id = %d\n",
e,eg_ptr->top_n[e]->goal_id);
fprintf(curr_out," top_n[%d]->path_ptr = %p\n",
e,eg_ptr->top_n[e]->path_ptr);
len = eg_ptr->top_n[e]->children_len;
for (k = 0; k < len; k++) {
fprintf(curr_out,
" top_n[%d]->goal[%d] = %s (%d)\n",
e,k,prism_goal_string(eg_ptr->top_n[e]->path_ptr->children[k]->id),eg_ptr->top_n[e]->path_ptr->children[k]->id);
fprintf(curr_out," top_n[%d]->top_n_index[%d] = %d\n",
e,k,eg_ptr->top_n[e]->top_n_index[k]);
}
fprintf(curr_out," top_n[%d]->max = %.9e\n",
e,eg_ptr->top_n[e]->max);
}
}
}
}
path_ptr = eg_ptr->path_ptr;
u = 0;
while (path_ptr != NULL) {
if (level == 0) {
fprintf(curr_out," path[%d]:\n",u);
}
if (level >= 3) {
fprintf(curr_out," path[%d].chilren_len = %d\n",
u,path_ptr->children_len);
fprintf(curr_out," path[%d].sws_len = %d\n",
u,path_ptr->sws_len);
}
if (level >= 1) {
if (log_scale1) {
fprintf(curr_out," path[%d].inside = %.9e (%.9e)\n",
u,path_ptr->inside,exp(path_ptr->inside));
}
else {
fprintf(curr_out," path[%d].inside = %.9e\n",
u,path_ptr->inside);
}
}
for (k = 0; k < path_ptr->children_len; k++) {
node_ptr = path_ptr->children[k];
if (level == 0) {
fprintf(curr_out," g[%d]:%s\n",
node_ptr->id,prism_goal_string(node_ptr->id));
}
if (level >= 3) {
fprintf(curr_out," g[%d]:%s.addr = <%p>\n",
node_ptr->id,prism_goal_string(node_ptr->id),
node_ptr);
}
if (level >= 1) {
if (log_scale1) {
fprintf(curr_out,
" g[%d]:%s.inside = %.9e (%.9e)\n",
node_ptr->id,
prism_goal_string(node_ptr->id),
node_ptr->inside,exp(node_ptr->inside));
fprintf(curr_out,
" g[%d]:%s.outside = %.9e (%.9e)\n",
node_ptr->id,
prism_goal_string(node_ptr->id),
node_ptr->outside,exp(node_ptr->outside));
fprintf(curr_out,
" g[%d]:%s.first_outside = %.9e (%.9e)\n",
node_ptr->id,
prism_goal_string(node_ptr->id),
node_ptr->first_outside,
exp(node_ptr->first_outside));
}
else {
fprintf(curr_out," g[%d]:%s.inside = %.9e\n",
node_ptr->id,
prism_goal_string(node_ptr->id),
node_ptr->inside);
fprintf(curr_out," g[%d]:%s.outside = %.9e\n",
node_ptr->id,
prism_goal_string(node_ptr->id),
node_ptr->outside);
}
}
}
for (k = 0; k < path_ptr->sws_len; k++) {
sw_ptr = path_ptr->sws[k];
if (level == 0) {
fprintf(curr_out," sw[%d]:%s\n",
sw_ptr->id,prism_sw_ins_string(sw_ptr->id));
}
if (level >= 1) {
if (mode == PRINT_EM) {
fprintf(curr_out," sw[%d]:%s.inside = %.9e\n",
sw_ptr->id,
prism_sw_ins_string(sw_ptr->id),
sw_ptr->inside);
fprintf(curr_out," sw[%d]:%s.total_e = %.9e\n",
sw_ptr->id,
prism_sw_ins_string(sw_ptr->id),
sw_ptr->total_expect);
}
if (mode == PRINT_VBEM) {
fprintf(curr_out," sw[%d]:%s.pi = %.9e\n",
sw_ptr->id,
prism_sw_ins_string(sw_ptr->id),
sw_ptr->pi);
fprintf(curr_out," sw[%d]:%s.smooth = %.9e\n",
sw_ptr->id,
prism_sw_ins_string(sw_ptr->id),
sw_ptr->smooth);
fprintf(curr_out," sw[%d]:%s.inside = %.9e\n",
sw_ptr->id,
prism_sw_ins_string(sw_ptr->id),
sw_ptr->inside);
fprintf(curr_out,
" sw[%d]:%s.inside_h = %.9e\n",
sw_ptr->id,
prism_sw_ins_string(sw_ptr->id),
sw_ptr->inside_h);
fprintf(curr_out," sw[%d]:%s.total_e = %.9e\n",
sw_ptr->id,
prism_sw_ins_string(sw_ptr->id),
sw_ptr->total_expect);
}
if (mode == PRINT_VITERBI) {
fprintf(curr_out," sw[%d]:%s.inside = %.9e\n",
sw_ptr->id,
prism_sw_ins_string(sw_ptr->id),
sw_ptr->inside);
}
}
}
path_ptr = path_ptr->next;
u++;
}
}
}
INIT_VISITED_FLAGS;
release_subgraph();
}
/*------------------------------------------------------------------------*/

15
packages/prism/src/c/up/graph_aux.h Normal file
View File

@ -0,0 +1,15 @@
#ifndef GRAPH_AUX_H
#define GRAPH_AUX_H
/*
* mode for print_egraph
* (positive for EM learning; negative for other inferences)
*/
#define PRINT_NEUTRAL 0
#define PRINT_EM 1
#define PRINT_VBEM 2
#define PRINT_VITERBI -1
void print_egraph(int, int);
#endif /* GRAPH_AUX_H */

300
packages/prism/src/c/up/hindsight.c Normal file
View File

@ -0,0 +1,300 @@
#include "up/up.h"
#include "up/graph.h"
#include "up/graph_aux.h"
#include "up/em_aux.h"
#include "up/em_aux_ml.h"
#include "up/flags.h"
#include "up/util.h"
/*------------------------------------------------------------------------*/
#define INIT_MAX_HINDSIGHT_GOAL_SIZE 100
/*------------------------------------------------------------------------*/
/* mic.c (B-Prolog) */
NORET quit(const char *);
/*------------------------------------------------------------------------*/
static int * hindsight_goals = NULL;
static double * hindsight_probs = NULL;
static int max_hindsight_goal_size;
static int hindsight_goal_size;
/*------------------------------------------------------------------------*/
static void alloc_hindsight_goals(void)
{
int i;
hindsight_goal_size = 0;
max_hindsight_goal_size = INIT_MAX_HINDSIGHT_GOAL_SIZE;
hindsight_goals = (int *)MALLOC(max_hindsight_goal_size * sizeof(TERM));
hindsight_probs =
(double *)MALLOC(max_hindsight_goal_size * sizeof(double));
for (i = 0; i < max_hindsight_goal_size; i++) {
hindsight_goals[i] = -1;
hindsight_probs[i] = 0.0;
}
}
static void expand_hindsight_goals(int req_hindsight_goal_size)
{
int old_size,i;
if (req_hindsight_goal_size > max_hindsight_goal_size) {
old_size = max_hindsight_goal_size;
while (req_hindsight_goal_size > max_hindsight_goal_size) {
max_hindsight_goal_size *= 2;
}
hindsight_goals =
(int *)REALLOC(hindsight_goals,
max_hindsight_goal_size * sizeof(TERM));
hindsight_probs =
(double *)REALLOC(hindsight_probs,
max_hindsight_goal_size * sizeof(double));
for (i = old_size; i < max_hindsight_goal_size; i++) {
hindsight_goals[i] = -1;
hindsight_probs[i] = 0.0;
}
}
}
/*
* Be warned that eg_ptr->outside will have a value different from that
* in the compute_expectation-family functions.
*/
int compute_outside_scaling_none(void)
{
int i,k;
EG_PATH_PTR path_ptr;
EG_NODE_PTR eg_ptr,node_ptr;
double q;
if (num_roots != 1) {
emit_internal_error("illegal call to compute_outside");
RET_ERR(build_internal_error("no_observed_data"));
}
for (i = 0; i < sorted_egraph_size; i++) {
sorted_expl_graph[i]->outside = 0.0;
}
eg_ptr = expl_graph[roots[0]->id];
eg_ptr->outside = roots[0]->count;
for (i = (sorted_egraph_size - 1); i >= 0; i--) {
eg_ptr = sorted_expl_graph[i];
path_ptr = eg_ptr->path_ptr;
while (path_ptr != NULL) {
q = eg_ptr->outside * path_ptr->inside;
if (q > 0.0) {
for (k = 0; k < path_ptr->children_len; k++) {
node_ptr = path_ptr->children[k];
node_ptr->outside += q / node_ptr->inside;
}
}
path_ptr = path_ptr->next;
}
}
return BP_TRUE;
}
int compute_outside_scaling_log_exp(void)
{
int i,k;
EG_PATH_PTR path_ptr;
EG_NODE_PTR eg_ptr,node_ptr;
double q,r;
if (num_roots != 1) {
emit_internal_error("illegal call to compute_outside");
RET_ERR(build_internal_error("no_observed_data"));
}
for (i = 0; i < sorted_egraph_size; i++) {
sorted_expl_graph[i]->outside = 0.0;
sorted_expl_graph[i]->has_first_outside = 0;
sorted_expl_graph[i]->first_outside = 0.0;
}
eg_ptr = expl_graph[roots[0]->id];
eg_ptr->outside = 1.0;
eg_ptr->has_first_outside = 1;
eg_ptr->first_outside = log((double)(roots[0]->count));
/* sorted_expl_graph[to] must be a root node */
for (i = sorted_egraph_size - 1; i >= 0; i--) {
eg_ptr = sorted_expl_graph[i];
/* First accumulate log-scale outside probabilities: */
if (!eg_ptr->has_first_outside) {
emit_internal_error("unexpected has_first_outside[%s]",prism_goal_string(eg_ptr->id));
RET_INTERNAL_ERR;
}
else if (!(eg_ptr->outside > 0.0)) {
emit_internal_error("unexpected outside[%s]",
prism_goal_string(eg_ptr->id));
RET_INTERNAL_ERR;
}
else {
eg_ptr->outside = eg_ptr->first_outside + log(eg_ptr->outside);
}
path_ptr = sorted_expl_graph[i]->path_ptr;
while (path_ptr != NULL) {
q = sorted_expl_graph[i]->outside + path_ptr->inside;
for (k = 0; k < path_ptr->children_len; k++) {
node_ptr = path_ptr->children[k];
r = q - node_ptr->inside;
if (!node_ptr->has_first_outside) {
node_ptr->first_outside = r;
node_ptr->outside += 1.0;
node_ptr->has_first_outside = 1;
}
else if (r - node_ptr->first_outside >= log(HUGE_PROB)) {
node_ptr->outside *= exp(node_ptr->first_outside - r);
node_ptr->first_outside = r;
node_ptr->outside += 1.0;
}
else {
node_ptr->outside += exp(r - node_ptr->first_outside);
}
}
path_ptr = path_ptr->next;
}
}
return BP_TRUE;
}
static int get_hindsight_goals_scaling_none(TERM p_subgoal, int is_cond)
{
int i,j;
EG_NODE_PTR eg_ptr;
TERM t;
double denom;
if (is_cond) {
denom = expl_graph[roots[0]->id]->inside;
}
else {
denom = 1.0;
}
j = 0;
for (i = 0; i < sorted_egraph_size - 1; i++) {
eg_ptr = sorted_expl_graph[i];
t = prism_goal_term((IDNUM)(eg_ptr->id));
if (bpx_is_unifiable(p_subgoal, t)) {
if (j >= max_hindsight_goal_size) expand_hindsight_goals(j + 1);
if (j >= hindsight_goal_size) hindsight_goal_size = j + 1;
hindsight_goals[j] = eg_ptr->id;
hindsight_probs[j] = eg_ptr->inside * eg_ptr->outside / denom;
j++;
}
}
return BP_TRUE;
}
static int get_hindsight_goals_scaling_log_exp(TERM p_subgoal, int is_cond)
{
int i,j;
EG_NODE_PTR eg_ptr;
TERM t;
double denom;
if (is_cond) {
denom = expl_graph[roots[0]->id]->inside;
}
else {
denom = 0.0;
}
j = 0;
for (i = 0; i < sorted_egraph_size - 1; i++) {
eg_ptr = sorted_expl_graph[i];
t = prism_goal_term(eg_ptr->id);
if (bpx_is_unifiable(p_subgoal, t)) {
if (j >= max_hindsight_goal_size) expand_hindsight_goals(j + 1);
if (j >= hindsight_goal_size) hindsight_goal_size = j + 1;
hindsight_goals[j] = eg_ptr->id;
hindsight_probs[j] = eg_ptr->inside + eg_ptr->outside - denom;
j++;
}
}
return BP_TRUE;
}
int pc_compute_hindsight_4(void)
{
TERM p_subgoal,p_hindsight_pairs,t,t1,p_pair;
int goal_id,is_cond,j;
goal_id = bpx_get_integer(bpx_get_call_arg(1,4));
p_subgoal = bpx_get_call_arg(2,4);
is_cond = bpx_get_integer(bpx_get_call_arg(3,4));
initialize_egraph_index();
alloc_sorted_egraph(1);
RET_ON_ERR(sort_one_egraph(goal_id,0,1));
if (verb_graph) print_egraph(0,PRINT_NEUTRAL);
alloc_hindsight_goals();
if (log_scale) {
RET_ON_ERR(compute_inside_scaling_log_exp());
RET_ON_ERR(compute_outside_scaling_log_exp());
RET_ON_ERR(get_hindsight_goals_scaling_log_exp(p_subgoal,is_cond));
}
else {
RET_ON_ERR(compute_inside_scaling_none());
RET_ON_ERR(compute_outside_scaling_none());
RET_ON_ERR(get_hindsight_goals_scaling_none(p_subgoal,is_cond));
}
if (hindsight_goal_size > 0) {
/* Build the list of pairs of a subgoal and its hindsight probability */
p_hindsight_pairs = bpx_build_list();
t = p_hindsight_pairs;
for (j = 0; j < hindsight_goal_size; j++) {
p_pair = bpx_build_list();
t1 = p_pair;
bpx_unify(bpx_get_car(t1),
bpx_build_integer(hindsight_goals[j]));
bpx_unify(bpx_get_cdr(t1),bpx_build_list());
t1 = bpx_get_cdr(t1);
bpx_unify(bpx_get_car(t1),bpx_build_float(hindsight_probs[j]));
bpx_unify(bpx_get_cdr(t1),bpx_build_nil());
bpx_unify(bpx_get_car(t),p_pair);
if (j == hindsight_goal_size - 1) {
bpx_unify(bpx_get_cdr(t),bpx_build_nil());
}
else {
bpx_unify(bpx_get_cdr(t),bpx_build_list());
t = bpx_get_cdr(t);
}
}
}
else {
p_hindsight_pairs = bpx_build_nil();
}
FREE(hindsight_goals);
FREE(hindsight_probs);
return bpx_unify(bpx_get_call_arg(4,4),p_hindsight_pairs);
}

15
packages/prism/src/c/up/hindsight.h Normal file
View File

@ -0,0 +1,15 @@
#ifndef HINDSIGHT_H
#define HINDSIGHT_H
/*============================================================================*/
int pc_compute_hindsight_4(void);
/*----------------------------------------------------------------------------*/
int compute_outside_scaling_none(void);
int compute_outside_scaling_log_exp(void);
/*============================================================================*/
#endif /* HINDSIGHT_H */

Some files were not shown because too many files have changed in this diff Show More