:- module( runtime_rm, [select_id/6] ).
:- use_module( library(random) ).
:- use_module( library(lists) ). % needed for last_skips/2.
/*
select_id_expr( Args, CArgs, Spec, LExs, LAs, Nth, H, T, Sel, Sid ) :-
% , Tail
evaluate_lbl_expressions_for( Spec, CArgs, LAs, LExs, Lbls ),
select_id( Args, CArgs, Lbls, Nth, H, T, Sel, Sid ).
*/
% select_id( Args, CArgs, LblsStr, Nth, H, T, Sel, Sid, Tail ) :-
select_id( Args, CArgs, LblsStr, Nth, H, Sid ) :-
/*
( (LblsStr = (split_leaf/5/_/_),ground(H)) ->
( bb_get( trace, TraceN ) ->
( TraceN =:= 2 ->
trace
;
NextTrace is TraceN + 1,
bb_put( trace, NextTrace )
)
;
bb_put( trace, 1 )
)
;
true
),
*/
( var(H) ->
( LblsStr = Spec/LExs/LAs ->
evaluate_lbl_expressions_for( Spec, CArgs, LAs, LExs, Lbls )
;
Lbls = LblsStr
),
add_unifying( Args, CArgs, Lbls, Nth, 0, _Unifs, ULs, Sum ),
random( GotRnd ),
Rnd is GotRnd * Sum,
select_label( ULs, Rnd, 1, [], Sid, Sprb ),
%% open( reconrd, append, Reconrd ),
%% write( Reconrd, selected(Rnd,Sid,Sprb) ), nl( Reconrd ),
%% close( Reconrd ),
% select_unified( Sum, ULs, Sid, Sprb ),
length( ULs, Cardin ),
cardin_to_path_point( Cardin, Sid, Sprb, H )
% Tail = T
;
% uncomment this one for excluding label support
% ( var(T) ->
% % reached proposal's backtracking point
% % user:bb_get( exclude_lbl, x(PrvExcl,Excl) ),
% /*
% ( bb_get( exclude_lbd, false ) ->
% Excl is -1
% ;
% H = bp(Excl/_ExcPrb)
% ),
% % NOTE Currently we dont have any excluding proposals...
% % we know there is at least one success in non excluding
% % strategies so we dont need backtracking here.
% % In chosen-clause-excluding proposals failure
% % will be caught in the kernel.
%
% ( LblsStr = Spec/LExs/LAs ->
% evaluate_lbl_expressions_for( Spec, CArgs, LAs, LExs, Lbls )
% ;
% Lbls = LblsStr
% ),
% add_unifying( Args, CArgs, Lbls, Nth, 0, _Unifs, ULs, Sum ),
% % add_unifying( Args, CArgs, Lbls, Nth, Excl, 0, _Unifs, ULs, Sum ),
% random( GotRnd ),
% Rnd is GotRnd * Sum,
% select_label( ULs, Rnd, 1, [], Sid, Sprb ),
% % select_unified( Sum, ULs, Sid, Sprb ),
% length( [H|ULs], Cardin ),
% cardin_to_path_point( Cardin, Sid, Sprb, Sel ),
% T = [Sel|Tail]
% ;
% )
( (H=Sid/_Hprb1;H=Sid:_Hprb2) -> true ;
write( user_error, 'Unrecognised lead-point: ' ),
write( user_error, H ), nl( user_error )
),
RelPos is Sid - Nth,
unify_nth0( RelPos, Args, CArgs ),
% fixme: is the following doing anything? Lbls are used nowhere...?!
( LblsStr = Spec/LExs/LAs ->
% following call can be removed if, (a) pvars for all
% s-predicates required/are-present, and (b) following call is
% adapted to use pvar definitions to do that on the fly.
% Currently i think (a) is too expensive for the depth case in
% carts and (b) will be quite expensive in all cases (we will
% need to test for groundness- which i assume is more expensive
% than testing for something being a variable.
evaluate_lbl_expressions_for( Spec, CArgs, LAs, LExs, _Lbls1 )
;
_Lbls2 = LblsStr
)
% T = Tail
% the above is experimental, use following if backtracking
% over concrete parts of the path is required.
% Currently we expect failures to be caught in kernel.
% add_unifying( Args, CArgs, Lbls, Nth, Excl, 0, _Unifs, ULs, Sum ),
% select_this_label(...).
).
% bb_get( pmember/2, ([Lst,_E],[Lgt-length(Lst,Lgt)]) )
% CArgs, are the called with arguments
evaluate_lbl_expressions_for( Spec, CArgs, LAs, LExs, Lbls ) :-
% bb_get( Spec, Args, LblvarCallPairs ),
( pvars:pvars( Spec, CArgs, LblvarCallPairs ) ->
true ; true % uniinstantiated is fine
),
% maybe we can add, flag controlled, warning
ground_lbl_arguments( LAs, LblvarCallPairs ),
evaluate_lbl_expressions( LExs, LAs, Lbls ).
ground_lbl_arguments( [], [] ).
ground_lbl_arguments( [H|T], [V-Call|Rest] ) :-
( var(H) ->
H = V,
% should add test for groundness of call,
% but it will make it more expensive
call( Call )
;
true
),
ground_lbl_arguments( T, Rest ).
evaluate_lbl_expressions( [], _Vals, [] ).
evaluate_lbl_expressions( [HExp-Vals|T], ValExps, [HLbl|TLbl] ) :-
expressions_to_values( ValExps, Vals ),
HLbl is HExp,
evaluate_lbl_expressions( T, Vals, TLbl ).
expressions_to_values( [], [] ).
expressions_to_values( [H|T], [Hvl|Tvl] ) :-
Hvl is H,
expressions_to_values( T, Tvl ).
% this will fail on select_unified, that had no unified, arguments.
/*
select_id( Args, A, Lbls, nth, H, T, Sel, Sid, Tail ) :-
%% write( lbls(Lbls) ), nl,
% Unifs can be eleminated, keep it here, just in case,
% we decide to hold it, as part of the path.
( var(H) ->
add_unifying( Args, A, Lbls, Nth, 0, 0, _Unifs, ULs, Sum ),
% first zero is a donot-exclude-any-id trick
select_unified( Sum, ULs, Sid, Sprb ),
length( ULs, Cardin ),
Tail = T
;
( T == [] ->
% write( run_h(H) ), nl,
H = Excl/_ExcPrb,
add_unifying( Args, A, Lbls, Nth, Excl, 0, _Unifs, ULs, Sum ),
% % Dec 15
% random( Rnd ),
% attach_ids_to_labels( ULs, 1, IdULs ),
% write( select_label( IdULs, Rnd, 1, [], Sid, Sprb ) ), nl,
% select_label( IdULs, Rnd, 1, [], Sid, Sprb ),
% write( select_label( IdULs, Rnd, 1, [], Sid, Sprb ) ), nl,
% end of Dec 15
select_unified( Sum, ULs, Sid, Sprb ),
% write( select_unified( Sum, ULs, Sid, Sprb ) ), nl,
length( ULs, ULlgt ),
( ULlgt =:= 1 -> Cardin is 0 ; Cardin is 2 )
% Tail = _
;
Tail = T,
( (H = Sid/Sprb;H = Sid:Sprb) ->
Cardin is 2
;
Cardin is 1,
Sid = H
)
)
),
( (Cardin>1,Sid=:=7,Sprb=:=1) -> trace ; true ),
cardin_to_path_point( Cardin, Sid, Sprb, Sel ).
*/
unify_nth0( N, [_H|T], U ) :-
N > 0,
!,
NxN is N - 1,
unify_nth0( NxN, T, U ).
unify_nth0( 0, [U|_T], U ).
add_unifying( [], _U, _Empty, _Nth, Sum, [], [], Sum ).
% add_unifying( [H|T], U, [L|Ls], Nth, Excl, Acc, Unifs, ULs, Sum ) :-
add_unifying( [H|T], U, [L|Ls], Nth, Acc, Unifs, ULs, Sum ) :-
NxN is Nth + 1,
% ( (Nth =\= Excl, \+ \+ H = U,L > 0) ->
( (\+ \+ H = U,L > 0) ->
NxAcc is Acc + L,
Unifs = [H|TUnifs],
ULs = [L-Nth|TUls]
;
NxAcc is Acc,
Unifs = TUnifs,
ULs = TUls
),
add_unifying( T, U, Ls, NxN, NxAcc, TUnifs, TUls, Sum ).
/*
select_unified( Sum, ULs, SelId, PrbSel ) :-
random:random( R ),
NormR is R * Sum,
select_from_unified_label( ULs, NormR, SelId, PrbSel ).
select_from_unified_label( [L-Id], _R, Id, L ) :- !.
select_from_unified_label( [L-Lid|T], R, Id, SeL ) :-
R =< L,
!,
Id = Lid, SeL = L.
select_from_unified_label( [L-_Lid|T], R, Id, SeL ) :-
NxR is R - L,
select_from_unified_label( T, NxR, Id, SeL ).
*/
select_this_label( Id, Label, _NS, _NxTotMass, Id, Label ).
select_this_label( _AnId, _ALbl, FromThese, TotMass, Id, Label ) :-
random( GotRnd ),
Rnd is GotRnd * TotMass,
select_label( FromThese, Rnd, TotMass, [], Id, Label ).
select_label( [HLbl-HId|T], Rnd, TotMass, Skp, Id, Label ) :-
Rnd < HLbl, % < because Rnd < 1 ?
!,
NxTotMass is TotMass - HLbl,
lists:append( Skp, T, NonSel ),
select_this_label( HId, HLbl, NonSel, NxTotMass, Id, Label ). %wb
% HId = Id, Label = HLbl. %nb
select_label( [HLbl-HId|T], Rnd, TotMass, Skp, Id, Label ) :-
NxRnd is Rnd - HLbl,
select_label( T, NxRnd, TotMass, [HLbl-HId|Skp], Id, Label ).
cardin_to_path_point( Cardin, Sid, Sprb, Sel ) :-
( Cardin > 1 ->
Sel = Sid/Sprb
;
Sel = Sid:Sprb
).
/*
This AVOIDS the creation of "pseudo"-backtracking points.
If there was a single unifying head clause, then no point is added.
It might be desirable in some cases to create such points,
for instance single clausal predicatess with 1 as their label.
This way, MCMC would be directed to also consider that point.
To implement such a strategy change Else part above, to: Sel = single(Sid)/Sprb).
Each backtracking proposal should bb_put a token about whether
these points can be backtracked to. Pick this token in
select_btrack_point/6 to stip single/1 or skip the point.
*/