view cpack/dml/lib/grammars.pl @ 0:718306e29690 tip

commiting public release

/* Part of DML (Digital Music Laboratory)
	Copyright 2014-2015 Samer Abdallah, University of London
	 
	This program is free software; you can redistribute it and/or
	modify it under the terms of the GNU General Public License
	as published by the Free Software Foundation; either version 2
	of the License, or (at your option) any later version.

	This program is distributed in the hope that it will be useful,
	but WITHOUT ANY WARRANTY; without even the implied warranty of
	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
	GNU General Public License for more details.

	You should have received a copy of the GNU General Public
	License along with this library; if not, write to the Free Software
	Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
*/

:- module(grammars,
      [  model_name/2
      ,  model_module_prep/3
      ,  build_options/2
      ,  build_subset_options/2
      ,  learn/6
      ,  learn_bpe/6
      ,  learn_model/7
      ,  model_sequence_parses/4
      ,  nnums_ivals/2
      ,  restart_prism/0
      ,  best_first/6
      ,  method_model_dataset_results/4
      ,  dataset_num_events/2
      ]).

:- multifile dataset_sequences/2.

:- use_module(library(memo)).
:- use_module(library(typedef)).
:- use_module(library(lambda)).
:- use_module(library(plml)).
:- use_module(library(prism/prism)).
:- use_module(library(argutils)).
:- use_module(library(snobol)).

:- type pmodule == ground.
:- type natural == nonneg.
:- type prep    == callable.
:- type options == ordset.
:- type model  ---> model(atom, list, prep, list(pair(ground,list(number)))).
:- type method ---> vb(ground) ; map(ground).
:- type matlab_method ---> vb ; map.

% % hmmmn.. maybe module issues here...
% error:has_type(\Checker,Term) :- call(Checker,Term).
error:has_type(ordset,Term) :- is_ordset(Term).

:- persistent_memo 
      learn( +method, +pmodule, +prep, +dataset:ground, +options, -scores:list),
      learn_model( +method, +pmodule, +prep, +dataset:ground, +options, -scores:list, -model),
      dataset_num_events( +dataset:ground, -num_events:nonneg).

dataset_num_events(Dataset,NumEvents) :-
   dataset_sequences(Dataset,Seqs),
   maplist(length,Seqs,Lens),
   sumlist(Lens,NumEvents).
   % aggregate_all(sum(L),(member(S,Seqs),length(S,L)),NumEvents).

:- initialization memo_attach(memo(learned),[]).
:- setting(timeout, number, 900, 'Time limit for learning in seconds').

user:file_search_path(prism,'psm').
user:matlab_path(grammars,['stats/hmm']).

partition_options([],[],[],[]).
partition_options([O|OX],[O|MO],IO,LO) :- option_class(O,model), partition_options(OX,MO,IO,LO).
partition_options([O|OX],MO,[O|IO],LO) :- option_class(O,init), partition_options(OX,MO,IO,LO).
partition_options([O|OX],MO,IO,[O|LO]) :- option_class(O,learn), partition_options(OX,MO,IO,LO).

option_class(switch_mode(_),model).
option_class(prior_weight(_),model).
option_class(gamut(_),model).
option_class(leap_range(_),model).
option_class(log_scale(_),learn).
option_class(O,init) :- \+option_class(O,model), \+option_class(O,learn).

option_mlopt(gamut(X-Y),gamut:[X,Y]) :- !.
option_mlopt(init(none),perturb:0) :- !.
option_mlopt(init(perturb(U)),perturb:U) :- !.
option_mlopt(F,N:V) :- F=..[N,V].

learn(vb(InitMeth),matlab(Function),Prepare,DataSet,Opts,[free_energy(FE)]) :- !,
   dataset_sequences(DataSet, D1),
	maplist(Prepare,D1,D),
   maplist(option_mlopt,[init(InitMeth)|Opts],Opts1),
   compileoptions(Opts1,Opts2),
   [float(FE)]===feval(@Function,cell(D),Opts2).

   % method dependent options

learn(Method,Module,Prepare,DataSet,Opts,Scores) :-
   member(Method,[vb(_),map(_)]),
   % prepare data
   dataset_sequences(DataSet, D1),
	maplist(Prepare,D1,D),
   % method dependent options
   method_switch_mode(Method,Mode),
   option(log_scale(LS), Opts, on),
   % load up prism and initialise
   restart_prism, load_prism(prism(Module)), 
   #init_model([switch_mode(Mode)|Opts]),
   #init_switches(Opts),
   set_prism_flag(log_scale,LS),
   % allow 15 minutes for learning
   setting(timeout, TimeLimit),
   get_time(Time),
   debug(learn,'Calling PRISM with time limit ~w at ~@...',
         [TimeLimit, format_time(current_output,'%T',Time)]),
   call_with_time_limit(TimeLimit, prism_learn(Method, D, [], Scores)).

method_switch_mode(vb(_),a).
method_switch_mode(map(_),d).

learn_model(Method,Module,Prepare,DataSet,Opts,Scores,model(Module,ModelOpts,Prepare,Counts)) :-
   % must re-compute to get final state
   compute(learn(Method,Module,Prepare,DataSet,Opts,Scores)),
   partition_options(Opts,ModelOpts,_,_),
   get_prism_state(ps(_,_,Counts1,_,_,_)),
   map_filter(unfixed_count,Counts1,Counts).

unfixed_count(sw(SW,a,set(unfixed,Counts)), SW-Counts).

model_initial_state(model(Module,MO,_,_),State) :-
   restart_prism,
   load_prism(prism(Module)),
   #init_model([switch_mode(a)|MO]),
   get_prism_state(State).

with_model_data(model(Module,MO,Prepare,Counts),Data,Goal) :-
   restart_prism, load_prism(prism(Module)),
   #init_model([switch_mode(a)|MO]),
   #maplist(SW-C,set_sw_a(SW,C),Counts),
   call(Prepare,Data,D),
   call(Goal,D).

learn_bpe(Method,Module,Prepare,DataSet,Opts,BPE) :-
   browse(learn(Method,Module,Prepare,DataSet,Opts,Scores)),
   catch( bits_per_event(Method,DataSet,Scores,BPE), _, fail).

bits_per_event(Method,DS,Scores,BPE) :-
   dataset_num_events(DS,NumEvents),
   score(Method,NumEvents,Scores,BPE).

score(map(_),NumEvents,Scores,BitsPerEvent) :-
	member(log_lik(LL), Scores),
	BitsPerEvent is -(LL/NumEvents)/log(2).

score(vb(_),NumEvents,Scores,BitsPerEvent) :-
	member(free_energy(LL), Scores),
	BitsPerEvent is -(LL/NumEvents)/log(2).

score(vb_pm(_),NumEvents,Scores,BitsPerEvent) :-
	member(free_energy(LL), Scores),
	BitsPerEvent is -(LL/NumEvents)/log(2).

%% tree_syntax(+Mod:module,+Tree:prism_tree,-Syntax:tree) is det.
%
%  Create a parse tree from a PRISM Viterbi tree.
%  Works for models gilbert1, gilbert2, gilbert2a, gilbert3 and gilbert2m.
tree_syntax(Mod,[s(_),TT],T2) :- tree_parse_tree(Mod,TT,T2).

tree_parse_tree(_,msw(i(I),terminal),node(t(I),[])).
tree_parse_tree(Mod,[pp(s,_,_)|Children],Term) :- member(Mod,[gilbert2,gilbert2a,gilbert3,gilbert2m]), !, 
   member(msw(s,Rule),Children),
   map_filter(tree_parse_tree(Mod),Children,CN),
   (  Rule=grow -> CN=[Child1,T1], T1=node(s,Tail), Term=node(s,[Child1|Tail])
   ;  Rule=last -> CN=[Child], Term=node(s,[Child])
   ).
tree_parse_tree(Mod,[pp(s,_,_)|Children],Term) :- Mod=gilbert1, !,
   member(msw(s,Rule),Children),
   map_filter(tree_parse_tree(Mod),Children,CN),
   (  Rule=grow -> CN=[Child1,T1], T1=node(s,Tail), Term=node(s,[Child1|Tail])
   ;  Rule=first -> CN=[], Term=node(s,[])
   ).
tree_parse_tree(Mod,[pp(H,_,_)|Children],Term) :- !, 
   map_filter(tree_parse_tree(Mod),Children,CN),
   member(msw(H,Rule1),Children),
   ( Rule1=terminal -> Rule=t; Rule=Rule1),
   Term = node(H-Rule,CN).

:- volatile_memo model_sequence_parses(+ground,+list(ground),+natural,-ground).

model_sequence_parses(Model,Seq,N,Parses) :- 
   Model=model(Mod,_,_,_), 
   with_model_data(Model,Seq,parses(Mod,N,Parses)).

parses(Mod,N,Parses,Goal) :- 
   succ(N,M),
   findall(P-T,viterbi_tree(M,Goal,P,[],T),ProbsTrees),
   append(NProbsTrees,[P0-_],ProbsTrees),
   maplist(tree_parse(Mod,P0),NProbsTrees,Parses).

tree_parse(Mod,P0,P-T,RP-S) :- tree_syntax(Mod,T,S), RP is P/P0.


% model declarations
decl_model(markov(nnum,0), p1gram,   markovp, with_nnums(s0)).
decl_model(markov(nnum,1), p2gram,   markovp, with_nnums(s1)).
decl_model(markov(ival,0), i1gram,   markovi, with_ivals(s0)).
decl_model(markov(ival,1), i2gram,   markovi, with_ivals(s1)).
decl_model(gilbert(1),     gilbert1, gilbert1, with_pre_ivals(s)).
decl_model(gilbert(2),     gilbert2, gilbert2, with_ivals(s)).
decl_model(gilbert(3),     gilbert3, gilbert3, with_ivals(s)).
decl_model(gilbert(2-a),   gilbert2a, gilbert2a, with_ivals(s)).
decl_model(gilbert(2-m),   gilbert2m, gilbert2m, with_ivals(s)).
% decl_model(gilbert(4),     gilbert1, gilbert1a, with_pre_ivals(s)).
% decl_model(gilbert(5),     gilbert2, gilbert2a, with_ivals(s)).
% decl_model(gilbert(6),     gilbert3, gilbert3a, with_ivals(s)).
decl_model(hmm(nnum),      phmm,     phmm,     with_nnums(s)).
decl_model(hmm(nnum,NS),   Name,     phmm,     with_nnums(s)) :- atom_concat(phmm,NS,Name).
%decl_model(hmm(ival),      ihmm,     ihmm,     with_ivals(s)).
decl_model(matlab(p1gram), 'ml-p1gram', matlab(p1gram), (=)). 
decl_model(matlab(p2gram), 'ml-p2gram', matlab(p2gram), (=)). 
decl_model(matlab(phmm),   'ml-phmm', matlab(phmm), (=)). 

model_name(Model,Name) :- decl_model(Model,Name,_,_).
model_module_prep(Model,Module,Prepare) :- decl_model(Model,_,Module,Prepare).

with_nnums(Head, Seq, Head1) :-
	addargs(Head,[Seq],Head1).

with_ivals(Head, Seq, Head1) :-
	nnums_ivals(Seq,Seq1),
	addargs(Head,[Seq1],Head1).

with_pre_ivals(Head, Seq, Head1) :-
	nnums_pre_ivals(Seq,Seq1),
	addargs(Head,[Seq1],Head1).

nnums_ivals(NNums,Ivals) :- nnums_post_ivals(NNums,Ivals).
nnums_post_ivals(NNums,Ivals) :- phrase((ivals(NNums),[end]),Ivals,[]).
nnums_pre_ivals(NNums,Ivals) :- phrase(([start],ivals(NNums)),Ivals,[]).

ivals([X0,X1|Xs]) --> {I1 is X1-X0}, [I1], ivals([X1|Xs]).
ivals([_]) --> [].

% NB option defaults here must match those in PRISM source files.
model_options(markov(nnum,_)) -->
   optopt(prior_shape, [binomial+0.1*uniform, binomial+uniform, uniform]),
   optopt(gamut,[40-100]).

model_options(markov(ival,_)) -->
   optopt(prior_shape, [uniform, binomial+uniform, binomial+0.1*uniform]).

model_options(gilbert(_)) -->
   [leap_range((-20)-(20))],
   optopt(leap_shape, [uniform, binomial+uniform, binomial+0.1*uniform]),
   optopt(pass_shape, [binomial, binomial+uniform, binomial+0.1*uniform]).

model_options(hmm(nnum)) -->
   optopt(prior_shape, [binomial+0.1*uniform, binomial+uniform, uniform]),
   anyopt(num_states, [1,2,3,5,7,12,18]),
   optopt(trans_self, [1]),
   % optopt(gamut,[40-100]).
   % anyopt(trans_self, [1]),
   anyopt(gamut,[40-100]).

model_options(hmm(nnum,NS)) -->
   [num_states(NS)],
   optopt(prior_shape, [binomial+0.1*uniform, binomial+uniform, uniform]),
   optopt(trans_self, [1]),
   % optopt(gamut,[40-100]).
   % anyopt(trans_self, [1]),
   anyopt(gamut,[40-100]).

model_options(hmm(ival)) -->
   optopt(prior_shape, [binomial+0.1*uniform, binomial+uniform, uniform]),
   anyopt(num_states, [5,7,12,24]),
   [leap_range((-20)-(20))].

model_options(matlab(p1gram)) -->
   optopt(prior_shape, [binomial+0.1*uniform, binomial+uniform, uniform]),
   optopt(gamut,[40-100]).

model_options(matlab(p2gram)) -->
   optopt(prior_shape, [binomial+0.1*uniform, binomial+uniform, uniform]),
   optopt(gamut,[40-100]).

model_options(matlab(phmm)) -->
   optopt(prior_shape, [binomial+0.1*uniform, binomial+uniform, uniform]),
   anyopt(num_states, [1,2,3,5,7,12,18]),
   optopt(gamut,[40-100]).

model_subset_options(markov(nnum,_)) --> [prior_shape(binomial+0.1*uniform)].
model_subset_options(markov(ival,_)) --> [prior_shape(binomial+0.1*uniform)].
model_subset_options(gilbert(_)) --> [].
model_subset_options(hmm(nnum)) --> 
   [prior_shape(binomial+0.1*uniform)], 
   anyopt(num_states,[2,5,7,12,18]).
model_subset_options(hmm(ival)) --> 
   [prior_shape(binomial+0.1*uniform), leap_range((-20)-(20))],
   anyopt(num_states,[2,5,7,12]).

build_options(Model,Opts) :-
   build_options(Model,Opts1,[]),
   sort(Opts1,Opts).

build_options(Model) -->
   optopt(prior_weight,[0.3,3,10]), % NB have removed 0.1 and 30
   model_options(Model).

build_subset_options(Model,Opts) :- 
   build_subset_options(Model,Opts1,[]),
   sort(Opts1,Opts).

build_subset_options(Model) -->
   optopt(prior_weight,[0.1,0.3,3,10,30]), 
   model_subset_options(Model).

anyopt(Name,Vals) --> {maplist(\X^Y^(Y=..[Name,X]),Vals,Opts)}, any(Opts).
optopt(Name,Vals) --> []; anyopt(Name,Vals).

best_first(Meth,Mod,Prepare,DS,Opts,learn(Meth,Mod,Prepare,DS,Opts,F)) :-
   order_by([asc(F)], learn_bpe(Meth,Mod,Prepare,DS,Opts,F)).

/* TODO: 
  Sort out HMM init options. They are all wrong:
      init_shape : shape of prior over initial state {uniform}
      trans_shape : shape of prior over transition distribution {uniform}
      trans_persistence : add self transtion counts {0,1,3}
      init_noise : perturbation of initial obs counts {0,0.1}
      restarts: {3}

   

   compare p2gram with hmm(1)
      */


%% map_filter(+P:pred(A,B),+Xs:list(A),-Ys:list(B)) is det.
%
%  map_filter(P,Xs,Ys) is similar to maplist(P,Xs,Ys), except that P is allowed to
%  fail and the resulting list Ys contains only those elements Y for which call(P,X,Y).
%  P is used as if it was semi-deterministic: only the first solution is accepted.
map_filter(_,[],[]).
map_filter(P,[X|XX],[Y|YY]) :- call(P,X,Y), !, map_filter(P,XX,YY).
map_filter(P,[_|XX],YY) :- map_filter(P,XX,YY).

user:file_search_path(home,X) :- expand_file_name('~',[X]).
user:file_search_path(prism,home('src/probprog/prism/psm')).
restart_prism :- prism_start('prism.log').

retry_on_error(G,M) :-
   catch((restart_prism,G,Status=ok), Ex, Status=error(Ex)),
   (  Status=ok -> true
   ;  format('*** terminated with ~w.\n',[Ex]),
      shell('say ALERT: THERE WAS AN ERROR!'),
      (  succ(N,M) -> retry_on_error(G,N)
      ;  writeln('failing after too many retries.'), 
         shell('say ALERT: I AM GIVING UP!'),
         shell('say ALERT: I AM GIVING UP!'),
         fail
      )
   ).

%% summary_array(+Meth:method,+Models:list(model),+Datasets:list(dataset),-Summary) is det.
summary_array(Meth,Models,Datasets,arr(Summary)) :-
   maplist( \Model^RR^maplist(\DS^{arr(R)}^method_model_dataset_results(Meth,Model,DS,R),Datasets,RR), Models,Summary).

%% method_model_dataset_results(+Method,+Model,+Dataset,Results:list(list(number))) is det.
method_model_dataset_results(Meth,Model,DS,Results) :- bagof( Row, datum(Meth,Model,DS,Row), Results).

%% datum(+Method:method,+Model:model,+Dataset,-Datum:list(number)) is nondet.
%
%  Maps trained models to a numerical tuple consisting of
%  the free energy (in bits per event), the prior weight parameter, and one or two 
%  shape parameters, depending on the model. The shape parameter is 0 for a uniform
%  prior, 1 for a binomial prior, and between 0 and 1 for linear interpolation between
%  the two.
%
%  Grammar models have leap_shape and pass_shape parameters, while the others
%  have a single prior_shape parameter.
datum(Meth,gilbert(I),DS,[FE,W,K1,K2]) :-
   model_module_prep(gilbert(I),Mod,Prep),
   learn_bpe(Meth,Mod,Prep,DS,Opts,FE),
   option(prior_weight(W),Opts,1),
   option(leap_shape(Sh1),Opts,binomial),
   option(pass_shape(Sh2),Opts,uniform),
   shape_param(Sh1,K1),
   shape_param(Sh2,K2).

datum(Meth,markov(Rep,Ord),DS,[FE,W,K]) :-
   model_module_prep(markov(Rep,Ord),Mod,Prep),
   learn_bpe(Meth,Mod,Prep,DS,Opts,FE),
   option(prior_weight(W),Opts,1),
   option(prior_shape(Sh),Opts,binomial),
   shape_param(Sh,K).

datum(Meth,hmm(Rep),DS,[FE,W,K]) :-
   model_module_prep(hmm(Rep),Mod,Prep),
   learn_bpe(Meth,Mod,Prep,DS,Opts,FE),
   option(prior_weight(W),Opts,1),
   option(prior_shape(Sh),Opts,binomial),
   shape_param(Sh,K).

datum(Meth,hmm(Rep,NS),DS,[FE,W,K]) :-
   model_module_prep(hmm(Rep),Mod,Prep),
   learn_bpe(Meth,Mod,Prep,DS,Opts,FE),
   option(num_states(NS),Opts),
   option(prior_weight(W),Opts,1),
   option(prior_shape(Sh),Opts,binomial),
   shape_param(Sh,K).

datum(Meth,matlab(F),DS,[FE,W,K]) :-
   model_module_prep(matlab(F),Mod,Prep),
   learn_bpe(Meth,Mod,Prep,DS,Opts,FE),
   option(prior_weight(W),Opts,1),
   option(prior_shape(Sh),Opts,binomial),
   shape_param(Sh,K).

shape_param(uniform,0).
shape_param(binomial,1).
shape_param(binomial+uniform,0.5).
shape_param(uniform+binomial,0.5).
shape_param(binomial+K*uniform,Lam) :- Lam = 1/(1+K).