Mercurial > hg > dml-open-cliopatria
diff cpack/dml/lib/computations.pl @ 0:718306e29690 tip
commiting public release
| author | Daniel Wolff |
|---|---|
| date | Tue, 09 Feb 2016 21:05:06 +0100 |
| parents | |
| children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/cpack/dml/lib/computations.pl Tue Feb 09 21:05:06 2016 +0100 @@ -0,0 +1,537 @@ +/* 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(computations, + [ computation/3 + , computation_memo/3 + , vamp/3 + , transform/2 + , transform_param/3 + , sparse_to_dense/4 + , fold_commutative/3 + , map_reduce/4 + , map_reduce/5 + , unzip/3 + , pair/3 + , add/3, mul/3, div_by/3 + , fst/3, snd/3 + , with_csv_rows/3 + , csv_op/3 + , (*)/4 + , array_list/2 + , microtone_map/4 + , rows_cols/3 + , tempo_curves_stats/3 + , map_edges/3 + , csv_pitch_count_prob/5 + , pitch_hist_prob/4 + , pitch_name_number/2 + , pitch_number_name/2 + , freq_note_number/2 + , histof/4 + , histof/3 + , weighted_histof/5 + , weighted_histof/4 + ]). + +:- use_module(library(rdfutils)). +:- use_module(library(dcg/basics)). +:- use_module(library(dcg_core)). +:- use_module(library(dcg_macros)). +:- use_module(library(csvutils)). +:- use_module(library(listutils)). +:- use_module(library(lambda)). +:- use_module(library(memo)). +:- use_module(library(mlserver)). +:- use_module(library(sandbox)). +:- use_module(library(backend_json)). +:- use_module(library(real)). + +:- volatile_memo pitch_name_number(+atom,-integer). + +:- initialization <-library(pracma). + +:- rdf_meta vamp(?,r,r). + +%% vamp(+T:transform_class, +R:uri, -X:uri) is nondet. +%% vamp(-T:transform_class, -R:uri, -X:uri) is nondet. +% +% See transform/2 for values transform_class type. +vamp(Class,In,Out) :- + transform(Class,F), + computation(F,In,Out). + +%% transform(+T:transform_class, -R:uri) is det. +%% transform(-T:transform_class, -R:uri) is nondet. +% +% Mapping between short transform descriptors and full VAMP transform URIs for +% transforms currently known to the system. Currently recognised transform classes are: +% == +% transform_class ---> transcription % equivalent to transcription(0) +% ; transcription({0,1}) % 0: semitone, 1:microtonal +% ; beats({beatroot,qm}) % beats using one of two plugins +% ; beats % beats using any plugin +% ; tempo +% ; chords +% ; chord_notes +% ; key +% ; tonic +% ; chromagram +% ; mfcc. +% == +transform(Class,Transform) :- + ground(Class), !, + transforms(Class,Transforms), + member(Transform,Transforms). +transform(Class,Transform) :- + transform1(Class,Transform). + +% memoised collection of all transforms +:- volatile_memo transforms(+ground,-list(atom)). +transforms(Class,Transforms) :- + findall(T,transform1(Class,T),Transforms). + +%% transform1(-Class:transform_class,-R:uri) is nondet. +% Searches the RDF database for resources of class vamp:Transform which +% match the various transform classes. See transform/2. +transform1(beats,Transform) :- transform1(beats(_),Transform). +transform1(transcription,Transform) :- transform1(transcription(0),Transform). +transform1(transcription(Fine),Transform) :- + transform1(notes,Transform), + transform_param(Transform,finetune,Lit), + literal_number(Lit,Fine). + +transform1(Class,Transform) :- + def_transform(Class,Plugin,Output), + rdf(Transform,vamp:plugin,Plugin), + rdf(Transform,vamp:output,Output). + +:- rdf_meta transform_param(r,r,-). +transform_param(Transform,ParamId,Value) :- + rdf(Transform,vamp:parameter_binding,Binding), + rdf(Binding,vamp:parameter,Param), + rdf(Param,vamp:identifier,literal(ParamId)), + rdf(Binding,vamp:value,literal(Value)). + + +:- rdf_meta def_transform(-,r,r). + +% transform class, plugin, output +def_transform(notes, vamp_plugins:'silvet#silvet', vamp_plugins:'silvet#silvet_output_notes'). +def_transform(pitch_activation, vamp_plugins:'silvet#silvet', vamp_plugins:'silvet#silvet_output_pitchactivation'). +def_transform(silvet_timefreq, vamp_plugins:'silvet#silvet', vamp_plugins:'silvet#silvet_output_timefreq'). +def_transform(beats(beatroot), vamp_plugins:'beatroot-vamp#beatroot', vamp_plugins:'beatroot-vamp#beatroot_output_beats'). +def_transform(beats(qm), vamp_plugins:'qm-vamp-plugins#qm-tempotracker', vamp_plugins:'qm-vamp-plugins#qm-tempotracker_output_beats'). +def_transform(tempo, vamp_plugins:'qm-vamp-plugins#qm-tempotracker', vamp_plugins:'qm-vamp-plugins#qm-tempotracker_output_tempo'). +def_transform(onset_dfn(tempo), vamp_plugins:'qm-vamp-plugins#qm-tempotracker', vamp_plugins:'qm-vamp-plugins#qm-tempotracker_output_detection_fn'). +def_transform(chords, vamp_plugins:'nnls-chroma#chordino', vamp_plugins:'nnls-chroma#chordino_output_simplechord'). +def_transform(chord_notes, vamp_plugins:'nnls-chroma#chordino', vamp_plugins:'nnls-chroma#chordino_output_chordnotes'). +def_transform(harmonic_change, vamp_plugins:'nnls-chroma#chordino', vamp_plugins:'nnls-chroma#chordino_output_harmonicchange'). +def_transform(key, vamp_plugins:'qm-vamp-plugins#qm-keydetector', vamp_plugins:'qm-vamp-plugins#qm-keydetector_output_key'). +def_transform(key_strength, vamp_plugins:'qm-vamp-plugins#qm-keydetector', vamp_plugins:'qm-vamp-plugins#qm-keydetector_output_keystrength'). +def_transform(tonic, vamp_plugins:'qm-vamp-plugins#qm-keydetector', vamp_plugins:'qm-vamp-plugins#qm-keydetector_output_tonic'). +def_transform(mode, vamp_plugins:'qm-vamp-plugins#qm-keydetector', vamp_plugins:'qm-vamp-plugins#qm-keydetector_output_mode'). +def_transform(mfcc, vamp_plugins:'qm-vamp-plugins#qm-mfcc', vamp_plugins:'qm-vamp-plugins#qm-mfcc_output_coefficients'). +def_transform(mfcc_means, vamp_plugins:'qm-vamp-plugins#qm-mfcc', vamp_plugins:'qm-vamp-plugins#qm-mfcc_output_means'). +def_transform(onsets, vamp_plugins:'qm-vamp-plugins#qm-onsetdetector',vamp_plugins:'qm-vamp-plugins#qm-onsetdetector_output_onsets'). +def_transform(onset_dfn, vamp_plugins:'qm-vamp-plugins#qm-onsetdetector',vamp_plugins:'qm-vamp-plugins#qm-onsetdetector_output_detection_fn'). +def_transform(onset_smoothed_dfn, vamp_plugins:'qm-vamp-plugins#qm-onsetdetector',vamp_plugins:'qm-vamp-plugins#qm-onsetdetector_output_smoothed_df'). +def_transform(chromagram, vamp_plugins:'qm-vamp-plugins#qm-chromagram', vamp_plugins:'qm-vamp-plugins#qm-chromagram_output_chromagram'). +def_transform(chromameans, vamp_plugins:'qm-vamp-plugins#qm-chromagram', vamp_plugins:'qm-vamp-plugins#qm-chromagram_output_chromameans'). +def_transform(chromagram(upper), vamp_plugins:'nnls-chroma#nnls-chroma', vamp_plugins:'nnls-chroma#nnls-chroma_output_chroma'). +def_transform(chromagram(bass), vamp_plugins:'nnls-chroma#nnls-chroma', vamp_plugins:'nnls-chroma#nnls-chroma_output_basschroma'). +def_transform(chromagram(both), vamp_plugins:'nnls-chroma#nnls-chroma', vamp_plugins:'nnls-chroma#nnls-chroma_output_bothchroma'). +def_transform(spectrogram(semitone), vamp_plugins:'nnls-chroma#nnls-chroma', vamp_plugins:'nnls-chroma#nnls-chroma_output_semitonespectrum'). +def_transform(spectrogram(log_freq), vamp_plugins:'nnls-chroma#nnls-chroma', vamp_plugins:'nnls-chroma#nnls-chroma_output_logfreqspec'). +def_transform(spectrogram(tuned), vamp_plugins:'nnls-chroma#nnls-chroma', vamp_plugins:'nnls-chroma#nnls-chroma_output_tunedlogfreqspec'). +def_transform(melody, vamp_plugins:'mtg-melodia#melodia', vamp_plugins:'mtg-melodai#melodia_output_melody'). +def_transform(spectrogram(const_q), vamp_plugins:'qm-vamp-plugins#qm-constantq', vamp_plugins:'qm-vamp-plugins#qm-constantq_output_constantq'). +def_transform(segments, vamp_plugins:'qm-vamp-plugins#qm-segmenter', vamp_plugins:'qm-vamp-plugins#qm-segmenter_output_segmentation'). +def_transform(speech_music, vamp_plugins:'bbc-vamp-plugins#bbc-speechmusic-segmenter', + vamp_plugins:'bbc-vamp-plugins#bbc-speechmusic-segmenter_output_segmentation'). +def_transform(speech_music_dfn, vamp_plugins:'bbc-vamp-plugins#bbc-speechmusic-segmenter', + vamp_plugins:'bbc-vamp-plugins#bbc-speechmusic-segmenter_output_skewness'). + + +%% computation_memo(+Transform:uri,+Input:uri,-Output:uri) is det. +% Memoised functional Relation between transforms, inputs and outputs. + +:- multifile do_computation/3. + +:- rdf_meta computation_memo(r,r,r). +computation_memo(Fn,Input,Output) :- + must_be(atom,Fn), + must_be(atom,Input), + must_be(var,Output), + ( computation(Fn,Input,Output) -> true + ; memo:timed(computations:do_computation(Fn,Input,Output),comp(_,Time,Dur)), + format_time(atom(Timestamp),'%FT%T%:z',Time), + memo:hostname(Host), + phrase( ( vamp:computation_triples(Comp,Input,Fn,Output), + vamp:rdf(Comp,dml:'comp/time',literal(type(xsd:dateTime,Timestamp))), + vamp:rdf(Comp,dml:'comp/duration',literal(type(xsd:float,Dur))), + vamp:rdf(Comp,dml:'comp/host',literal(Host)) + ), Triples,[]), + forall(member(rdf(S,P,O),Triples), rdf_assert(S,P,O,vamp_memo)) + ). + + +%% computation(-Transform:uri,-Input:uri,-Output:uri) is nondet. +% Relation between transforms, inputs and outputs using RDF database +% of existing computations. + +:- rdf_meta computation(r,r,r). +computation(Fn,Input,Output) :- nonvar(Output), !, + rdf(Comp,dml:'comp/output',Output), + rdf(Comp,dml:'comp/function',Fn), + rdf(Comp,dml:'comp/input',Input). + +computation(Fn,Input,Output) :- nonvar(Input), !, + rdf(Comp,dml:'comp/input',Input), + rdf(Comp,dml:'comp/function',Fn), + rdf(Comp,dml:'comp/output',Output). + +computation(Fn,Input,Output) :- + rdf(Comp,dml:'comp/input',Input), + rdf(Comp,dml:'comp/function',Fn), + rdf(Comp,dml:'comp/output',Output). + +% ------------ Framework for doing computations on CSV files ----------- +:- meta_predicate with_csv_rows(2,+,-). +with_csv_rows(Pred,CSV,Result) :- + insist(uri_to_csv(CSV,Rows)), + insist(call(Pred,Rows,Result), failed_on_csv(Pred,CSV)). + +csv_op(Op,CSV,Result) :- + ( memoise(Op) + -> csv_op_memo(Op,CSV,Result) % ,_-ok) + ; with_csv_rows(row_op(Op),CSV,Result) + ), + debug(computations(item),'Done csv_op(~q,~q).',[Op,CSV]). + +sandbox:safe_primitive(computations:csv_op(_,_,_)). + +:- persistent_memo csv_op_memo(+ground,+atom,-ground). +csv_op_memo(Op,CSV,Result) :- with_csv_rows(row_op(Op),CSV,Result). + +:- initialization time(memo_attach(memo(computations2),[])). + +memoise(pitch_hist(_)). +memoise(freq_hist(_,_)). +memoise(tempo_hist(_,_)). +memoise(uniform_tempo(_)). +memoise(uniform_tempo_r(_)). +memoise(normalised_tempo(_)). +memoise(normalised_tempo_r(_)). + +row_op(id,Rows,Rows) :- !. +row_op(column(N),Rows,Vals) :- !, maplist(arg(N),Rows,Vals). +row_op(array,Rows,Array) :- !, maplist(row_list(_),Rows,Array). +row_op(chord_hist,Rows,Hist) :- !, histof(Chord,T,member(row(T,Chord),Rows),Hist). +row_op(pitch_hist(none),Rows,Hist) :- !, histof(Pitch,t(T,Dur),note(Rows,T,Dur,Pitch),Hist). +row_op(pitch_hist(W),Rows,Hist) :- !, weighted_histof(Weight,Pitch,t(T,Dur),weighted_note(W,Rows,T,Dur,Pitch,Weight),Hist). +row_op(beat_times,Rows,Times) :- !, row_op(column(1),Rows,Times). +row_op(onset_times,Rows,Times) :- !, row_op(column(1),Rows,Times). +row_op(tempo,Rows,Tempo) :- !, maplist(row_pair(1,2),Rows,Tempo). +row_op(uniform_tempo(DT),Rows,Samples) :- !, row_op(tempo,Rows,Tempo), uniform_sample(ml,cubic,DT,Tempo,Samples). +row_op(uniform_tempo_r(DT),Rows,Samples) :- !, row_op(tempo,Rows,Tempo), uniform_sample(r,cubic,DT,Tempo,Samples). +row_op(uniform_tempo(Meth,DT),Rows,Samples) :- !, row_op(tempo,Rows,Tempo), uniform_sample(ml,Meth,DT,Tempo,Samples). +row_op(uniform_tempo_r(Meth,DT),Rows,Samples) :- !, row_op(tempo,Rows,Tempo), uniform_sample(r,Meth,DT,Tempo,Samples). +row_op(normalised_tempo(N),Rows,Samples) :- !, row_op(tempo,Rows,Tempo), normalised_sample(ml,N,Tempo,Samples). +row_op(normalised_tempo_r(N),Rows,Samples) :- !, row_op(tempo,Rows,Tempo), normalised_sample(r,N,Tempo,Samples). +row_op(tempo_hist(DT,Map),Rows,Edges-Counts) :- !, + row_op(uniform_tempo(DT),Rows,_-Tempo), + M===Map, + [arr(Counts), arr(Edges)] === + deal(accumhist(flatten(feval(M,Tempo)),1,cardr(M)), flatten(edges(M))). + +row_op(tempo_hist_r(DT,Map),Rows,Edges-Counts) :- !, + map_to_r_edges(Map,REdges), + row_op(uniform_tempo_r(DT),Rows,_-Tempo), + Counts <- table(cut(Tempo,breaks=REdges)), + Edges <- REdges. + % memberchk(counts=Counts,Hist), + % memberchk(breaks=Edges,Hist). + +row_op(freq_hist(Map1,W),Rows,Counts) :- + column(transcription,freq,J), + ( W=none + -> maplist(arg(J),Rows,Freqs), Weights=1 + ; column(transcription,W,I), + rows_cols([J,I],Rows,[Freqs,Weights]) + ), + Map===Map1, % evaluate map and keep in Matlab workspace + X=feval(Map,12*log2(Freqs)-(12*log2(440)-69)), + array_list(accumhist(flatten(X),flatten(Weights),cardr(Map)),Counts). + +row_op(freq_hist_r(Map1,W),Rows,Counts) :- + column(transcription,freq,J), + map_to_r_edges(Map1,REdges), + Pitches=12*log2(Freqs)-(12*log2(440)-69), + ( W=none + -> maplist(arg(J),Rows,Freqs), + Hist <- hist(Pitches,breaks=REdges,plot=0) + ; column(transcription,W,I), + rows_cols([J,I],Rows,[Freqs,Weights]), + Hist <- hist(Pitches,Weights,breaks=REdges,plot=0) + ), + memberchk(counts=Counts,Hist). + +map_edges(r,Map,Edges) :- + map_to_r_edges(Map,Expr), + Edges <- Expr. +map_edges(ml,Map,Edges) :- + array_list(edges(Map),Edges). + +map_to_r_edges(expmap(Min,Max,N),sapply(seq(log(Min),log(Max),len=N+1),exp)). +map_to_r_edges(binmap(Min,Max,N),seq(Min-HalfWidth,Max+HalfWidth,len=N+1)) :- HalfWidth=(Max-Min)/(2*(N-1)). + +column(Format, Name, Number) :- csv(Format,Row), arg(Number,Row,Name). +csv(transcription, row(time,dur,freq,vel,pitch)). + +gather(P,Rows,Xs) :- findall(X,(member(R,Rows),call(P,R,X)),Xs). + + +microtone_map(Min,Max,Res,binmap(Min,Max,N)) :- N is (Max-Min)*Res+1. + +% qfreq(Q,Rows,T,Dur,QFreq) :- member(row(T,Dur,Freq,_,_),Rows), qlogfreq(Q,Freq,QFreq). +% weighted_qfreq(dur,Q,Rows,T,Dur,QFreq,Dur) :- member(row(T,Dur,Freq,_,_),Rows), qlogfreq(Q,Freq,QFreq). +% weighted_qfreq(vel,Q,Rows,T,Dur,QFreq,Vel) :- member(row(T,Dur,Freq,Vel,_),Rows), qlogfreq(Q,Freq,QFreq). +% qlogfreq(Q,In,Out) :- B is 12/log(2), Out is 69+round(Q*B*(log(In)-log(440)))/Q. +% goal_expansion(qlogfreq(Q,In,Out), Out is 69+round(Q*B*(log(In)-A))/Q) :- B is 12/log(2), A=log(440). + +uniform_sample(DT,In,Out) :- uniform_sample(ml,linear,DT,In,Out). + +uniform_sample(_,_,_,[Time-Val],[Time]-[Val]) :- !. +uniform_sample(Lang,Meth,DT,Pairs,Times1-Vals1) :- + unzip(Pairs,Times,Vals), + aggregate(max(T), member(T,Times), MaxT), + interp1(Lang,Meth,0:DT:MaxT,Times,Vals,Times1,Vals1). + +normalised_sample(N,In,Out) :- normalised_sample(ml,N,In,Out). + +normalised_sample(_,N,[Time-Val],Times-Vals) :- !, + rep(N,Time,Times), + rep(N,Val,Vals). +normalised_sample(Lang,N,Pairs,Times1-Vals1) :- + unzip(Pairs,Times,Vals), + aggregate(max(T), member(T,Times), MaxT), + interp1(Lang,cubic,linspace(0,MaxT,N),Times,Vals,Times1,Vals1). + +interp1(ml,Meth,TSpec,Times,Vals,Times1,Vals1) :- + length(Times,N), + (N<4 -> Method=q(linear); Method=q(Meth)), + T1===flatten(TSpec), + [arr(Times1), arr(Vals1)]===deal(T1,interp1(Times,Vals,T1,Method)). +interp1(r,Meth,TSpec,Times,Vals,Times1,Vals1) :- + ml_r(TSpec,RTSpec), + length(Times,N), + (N<4 -> Method = +linear; Method = +Meth), + Times1 <- RTSpec, + Vals1 <- interp1(Times,Vals,Times1,Method). + +ml_r(X1:DX:X2, seq(X1,X2,DX)). +ml_r(linspace(X1,X2,N), seq(X1,X2,len=N)). + +array_list(Array,List) :- arr(List)===flatten(Array). + +:- meta_predicate '*'(2,2,+,-). +*(F1,F2,X,Y) :- call(F1,X,Z), call(F2,Z,Y). + +note(Rows,T,Dur,NN) :- member(row(T,Dur,_,_,Pitch),Rows), pitch_name_number(Pitch,NN). + +weighted_note(dur,Rows,T,Dur,NN,Dur) :- member(row(T,Dur,_,_,Pitch),Rows), pitch_name_number(Pitch,NN). +weighted_note(vel,Rows,T,Dur,NN,Vel) :- member(row(T,Dur,_,Vel,Pitch),Rows), pitch_name_number(Pitch,NN). +weighted_note(dur*vel,Rows,T,Dur,NN,Weight) :- + member(row(T,Dur,_,Vel,Pitch),Rows), pitch_name_number(Pitch,NN), + Weight is Dur*Vel. + + +tempo_curves_stats(ml,Curves, _{means:Means,std_devs:StdDevs}) :- + Data===arr(Curves), + array_list(mean(Data,2),Means), + array_list(std(Data,0,2),StdDevs). + +tempo_curves_stats(r,Curves, _{means:Means,std_devs:Stds}) :- + data <- Curves, + Means <- apply(data,2,mean), + Stds <- apply(data,2,sd). + +:- meta_predicate histof(-,0,-) + , histof(-,-,0,-) + , weighted_histof(-,-,0,-) + , weighted_histof(-,-,-,0,-) + . + +%% histof(@Dom:A,+Goal:callable,-Hist:list(pair(A,natural))) is nondet. +% Compile a histogram over values taken by the variable Dom while enumerating +% all solutions of Goal. Repeated solutions of Goal with the same values +% count as distinct observations. See also histof/4. +histof(Dom,Goal,Hist) :- + setof(Dom-N,aggregate(count,Goal,N),Hist). + +%% histof(@Dom:A,@Disc:_,+Goal:callable,-Hist:list(pair(A,natural))) is nondet. +% Compile a histogram over values taken by the variable Dom while enumerating +% all solutions of Goal. The value of Disc is used to discriminate between +% solutions of Goal with the same value of Dom. See also histof/3 and aggregate/4 +% for more information about discriminator variables. +histof(Dom,Disc,Goal,Hist) :- + setof(Dom-N,aggregate(count,Disc,Goal,N),Hist). + +weighted_histof(W,Dom,Goal,Hist) :- + setof(Dom-N,aggregate(sum(W),Goal,N),Hist). + +weighted_histof(W,Dom,Disc,Goal,Hist) :- + setof(Dom-N,aggregate(sum(W),Disc,Goal,N),Hist). + +sparse_to_dense(Min,Max,Hist,Counts) :- + s_to_d(Min,Max,Hist,Counts). + +s_to_d(I,Max,[],[]) :- I>Max, !. +s_to_d(I,Max,[],[0|Counts]) :- !, succ(I,J), s_to_d(J,Max,[],Counts). +s_to_d(I,Max,[I-C|Hist],[C|Counts]) :- !, succ(I,J), s_to_d(J,Max,Hist,Counts). +s_to_d(I,Max,Hist,[0|Counts]) :- succ(I,J), s_to_d(J,Max,Hist,Counts). + + +add(X,Y,Z) :- Z is X+Y. + +:- meta_predicate + map_reduce(1,2,3,-), + map_reduce(1,2,3,-,-), + fold_commutative(3,+,-). + +%% map_reduce(+Generator:pred(-R), +Mapper:pred(+R,-A), +Reducer:pred(+A,+A,-A), -Result:A, -Errors:list(error_report(R))) is det. +%% map_reduce(+Generator:pred(-R), +Mapper:pred(+R,-A), +Reducer:pred(+A,+A,-A), -Result:A) is semidet. +% +% Simple implementation of map-reduce: Mapper is applied to each item produced by Generator +% and the results all combined using Reducer. Mapper should be a deterministic predicate. +% Failures and exceptions encountered in the mapping phase are reported in Errors. +% However, if the items are successfully mapped, this predicate fails. +% Any choice points left by mapper after its first solution are cut. +% +% == +% error_report(R) ---> failed(R); error(R,exception). +% == +map_reduce(Finder,Mapper,Reducer,Result) :- + map_reduce(Finder,Mapper,Reducer,Result,_). + +map_reduce(Finder,Mapper,Reducer,Result,Errors-Failures) :- + setof(X,call(Finder,X),Xs), + maplist(safe_call(Mapper),Xs,Ys), + partition_ok(Ys,Ok,Errors,Failures), + insist(fold_commutative(Reducer,Ok,Result)). + +%% safe_call(+P:pred(+A,-B), +X:A, -Y:result(A,B)) is det. +% +% Call binary predicate P with arguments of type A and B. The result +% term Y is of type +% == +% result(A,B) ---> ok(B); failed(A); error(A,exception). +% == +% and encodes the result of the call, including the input value that +% caused any failure or exception. +safe_call(Mapper,X,Z) :- + ( catch((call(Mapper,X,Y), Z=ok(Y)), Ex, + (Ex=abort_map -> throw(map_aborted); Z=error(X,Ex))), ! + ; Z=failed(X) + ). + +partition_ok([],[],[],[]). +partition_ok([In|Ins],Goods,Bads,Uglies) :- + ( In=ok(X) + -> Goods=[X|Goods1], partition_ok(Ins,Goods1,Bads,Uglies) + ; In=error(_,_) + -> Bads=[In|Bads1], partition_ok(Ins,Goods,Bads1,Uglies) + ; In=failed(X) + -> Uglies=[X|Uglies1], partition_ok(Ins,Goods,Bads,Uglies1) + ). + +fold_commutative(Op,Items,Result) :- + Items=[I1|Rest], + seqmap(Op,Rest,I1,Result), !. + +freq_note_number(F,N) :- N is 69+round(12*log(F/440)/log(2)). + +pitch_name_number(Name,Number) :- + atom_codes(Name,Chars), + phrase(note(Number),Chars). + +pitch_number_name(Number,Name) :- + phrase(note(Number),Chars), + atom_codes(Name,Chars). + +:- use_module(library(clpfd)). +note(Num) --> + [Nom], ({Mod=0}; [0'#],{Mod=1}), + { PC in 0..11, + Num #= 12*(Oct+1)+PC+Mod, + nom_semis(Nom,PC) + }, + integer(Oct). + +nom_semis(0'C,0). +nom_semis(0'D,2). +nom_semis(0'E,4). +nom_semis(0'F,5). +nom_semis(0'G,7). +nom_semis(0'A,9). +nom_semis(0'B,11). + +unzip(Pairs,Xs,Ys) :- maplist(pair,Xs,Ys,Pairs). +pair(X,Y,X-Y). + +row_pair(I,J,Row,X-Y) :- arg(I,Row,X), arg(J,Row,Y). +row_list(N,Row,List) :- functor(Row,_,N), Row=..[_|List]. +rows_cols(Is,[],Cols) :- !, maplist(nil,Is,Cols). +rows_cols(Is,[R|Rs],Cols) :- + ( maplist(arg_cons(R),Is,Tails,Cols) + -> rows_cols(Is,Rs,Tails) + ; fail % rows_cols(Is,Rs,Cols) + ). + +arg_cons(Row,I,T,[X|T]) :- arg(I,Row,X). +nil(_,[]). + +fst(F,K1-V,K2-V) :- call(F,K1,K2). +snd(F,K-V1,K-V2) :- call(F,V1,V2). +div_by(K,X,Y) :- Y is X/K. + +mul(X,Y,Z) :- Z is round(X*Y). + +:- dynamic pitch_hist_table/5, pitch_hist_tabled/1. + +csv_pitch_count_prob(W,CSV,Pitch,Count,Prob) :- + must_be(ground,W), + ( pitch_hist_tabled(W) -> true + ; table_pitch_hist(W) + ), + pitch_hist_table(W,CSV,Pitch,Count,Prob). + +table_pitch_hist(W) :- + retractall(pitch_hist_table_cached(W)), + forall( browse(csv_op_memo(pitch_hist(W),CSV,Hist)), + ( retractall(pitch_hist_table(W,CSV,_,_,_)), + forall( pitch_hist_prob(Hist,Pitch,Count,Prob), + assert(pitch_hist_table(W,CSV,Pitch,Count,Prob))))), + assert(pitch_hist_tabled(W)). + +pitch_hist_prob(Hist,Pitch,Count,Prob) :- + unzip(Hist,_,Counts), + sumlist(Counts,Total), + member(Pitch-Count,Hist), + Prob is Count/Total.