/*  PS.PL  */


:- module ps.


:- public /.


/*
SPECIFICATION
-------------
*/


/*
IMPLEMENTATION
--------------

bagof not portable.
*/


ps( Time, Rules, STM0, StopPred, SR, WE, Context0, STM ) :-
    WE:report( ps, start, Time ),
    WE:report( ps, stm, stm_(STM0,4) ),
    match( Rules, STM0, Matched ),
    WE:report( ps, matched(Matched) ),
    Matched \= [],
    !,
    resolve( Matched, STM0, SR, Context0, Resolved ),
    we_report( WE, ps, 'Resolved to give rule'...rules_(Resolved,4)~ ),
    fire( Resolved, Time, STM0, Context0, STM1, Context1 ),
    we_report( WE, ps, 'STM is'...stm_(STM1,4)~~ ),
    Time1 is Time + 1,
    ps_continue_if_necessary( Time1, Rules, STM1, StopPred, SR, WE, Context1, STM ).

ps( _, _, _, _, _, _, _, _ ) :-
    true.
    /* if no rules matched.  */


ps_continue_if_necessary( Time, Rules, STM, StopPred, SR, WE, Context, STM ) :-
    Goal =.. [ StopPred, STM ],
    call( Goal ),
    !.

ps_continue_if_necessary( Time, Rules, STM0, StopPred, SR, WE, Context, STM ) :-
    ps( Time, Rules, STM0, StopPred, SR, WE, Context, STM ).


ps( Rules, STM0, StopPred, SR, WE, STM ) :-
    ps( 1, Rules, STM0, StopPred, SR, WE, [], STM ).


ps( Rules, STM0, StopPred, SR, STM ) :-
    ps( Rules, STM0, StopPred, SR, no_ved, STM ).


fire( Rule, Time, STM0, Context0, STM, Context ) :-
    rule_vs_action( Rule, Action ),
    fire_all( STM0, Time, Action, STM ),
    Context = [ fired(Rule,Time) | Context0 ].


fire_all( STM, _, [], STM ) :- !.

fire_all( STM0, Time, [Action1|ActionsN], STM ) :-
    fire_one( STM0, Time, Action1, STM1 ),
    fire_all( STM1, Time, ActionsN, STM ).


fire_one( STM0, Time, erase(Term), STM1 ) :-
    !,
    stm_delete( STM0, Time, Term, STM1 ).

fire_one( STM0, Time, Term, STM1 ) :-
    stm_insert( STM0, Time, Term, STM1 ).


/*
Matching.
---------
*/


match( Rules, STM, Matched ) :-
    fast_bagof(
            Rule,
            (   rules_member( Rule, Rules ),
                rule_vs_condition( Rule, Cond ),
                match_cond( Cond, STM )
            ),
            Matched
         ).


match_cond( [], _ ) :- !.

match_cond( [C1|CN], STM ) :-
    !,
    match_primitive_cond( C1, STM ),
    match_cond( CN, STM ).


match_primitive_cond( X>Y, _ ) :- !, X > Y.

match_primitive_cond( X>=Y, _ ) :- !, X >= Y.

match_primitive_cond( X<Y, _ ) :- !, X < Y.

match_primitive_cond( X=<Y, _ ) :- !, X =< Y.

match_primitive_cond( Term, STM ) :-
    stm_member( Term, STM ).


/*
Conflict resolution.
--------------------
*/


resolve( [], STM, _, Context, _ ) :-
    !,
    bug( 'resolve: no rules', [STM,Context] ).

resolve( [Rule], _, _, _, Rule ) :- !.

resolve( Rules, STM, SR, Context, Rule ) :-
    (
        SR = sr
    ->
        resolve_by_specificity( Rules, STM, MostSpecific ),
        resolve_by_recency( MostSpecific, STM, Context, [Rule|_] )
    ;
        SR = rs
    ->
        resolve_by_recency( Rules, STM, Context, LeastRecent ),
        resolve_by_specificity( LeastRecent, STM, [Rule|_] )
    ;
        SR = s
    ->
        resolve_by_specificity( Rules, STM, [Rule|_] )
    ;
        SR = r
    ->
        resolve_by_recency( Rules, STM, Context, [Rule|_] )
    ;
        bug( 'resolve: bad SR', [Rules, STM, SR, Context] )
    ).


resolve_by_specificity( Rules, STM, MostSpecific ) :-
    tag_by_unspecificity( Rules, TaggedRules ),
    keysort( TaggedRules, Sorted ),
    untag( Sorted, MostSpecific ).


resolve_by_recency( Rules, STM, Context, LeastRecent ) :-
    tag_by_time( Rules, Context, TaggedRules ),
    keysort( TaggedRules, Sorted ),
    untag( Sorted, LeastRecent ).


tag_by_unspecificity( [], [] ) :- !.

tag_by_unspecificity( [Rule|Rules], [MinusS-Rule|Taggeds] ) :-
    rule_condition( Rule, Cond ),
    conditions_specificity( Cond, S ),
    MinusS is -S,
    !,
    tag_by_unspecificity( Rules, Taggeds ).


conditions_specificity( L, S ) :-
    conditions_specificity( L, 0, 0, S ).


conditions_specificity( [], Sum, Count, S ) :-
    !,
    S is Sum.
    /*  Don't take average.  */

conditions_specificity( [C1|Cn], Sum0, Count0, S ) :-
    condition_specificity( C1, CS ),
    Sum1 is Sum0 + CS,
    Count1 is Count0 + 1,
    conditions_specificity( Cn, Sum1, Count1, S ).


condition_specificity( C1, CS ) :-
    C1 =.. [ _ | Args ],
    args_specificity( Args, AS ),
    CS is AS + 1.


args_specificity( Args, S ) :-
    args_specificity( Args, 0, S ).


args_specificity( [], S, S ) :- !.

args_specificity( [A1|AN], S0, S ) :-
    var(A1),
    !,
    S1 is S0 + 0.5,
    args_specificity( AN, S1, S ).

args_specificity( [A1|AN], S0, S ) :-
    S1 is S0 + 1,                    
    args_specificity( AN, S1, S ).


tag_by_time( [], _, [] ) :- !.

tag_by_time( [Rule|Rules], Context, [Time-Rule|Taggeds] ) :-
    member( fired(Rule,Time), Context ),
    !,
    tag_by_time( Rules, Context, Taggeds ).

tag_by_time( [Rule|Rules], Context, [0-Rule|Taggeds] ) :-
    tag_by_time( Rules, Context, Taggeds ).


untag( [], [] ) :- !.

untag( [_-H|T], [H|T1] ) :-
    untag( T, T1 ).


/*
Rules.
------
*/


rule_vs_action( rule(_,Action), Action ).


rule_vs_condition( rule(Cond,_), Cond ).


rules_member( Rule, Rules ) :-
    member( Rule, Rules ).


rule_insert( Rules, Rule, [Rule|Rules] ).


show_rules( Rules, Indent ) :-
    forall(
        rule_member( rule(Cond,Action), Rules ),
        output( spaces_(Indent)<>rule(Cond,Action)~ )
    ).


/*
STM.
----
*/


new_stm( stm(0,0,[]) ).


stm_insert( stm(LastTime,LastTag,Facts0), Time, Term, stm(Time,Tag,Facts) ) :-
    (
        LastTime = Time
    ->
        Tag is LastTag + 1
    ;
        Tag = 1
    ),
    TimeStamp is Time*1000 + Tag,
    Facts = [ fact(Term,TimeStamp) | Facts0 ].


stm_delete( stm(LastTime,LastTag,Facts0), Time, Term, stm(Time,Tag,Facts) ) :-
    (
        LastTime = Time
    ->
        Tag is LastTag + 1
    ;
        Tag = 1
    ),
    delete( Facts0, fact(Term,_), Facts ).
    /*  Variables in Term must remain unbound. This is ensured by
        'delete'.
    */


stm_member( Term, TimeStamp, stm(_,_,Facts) ) :-
    member( fact(Term,TimeStamp), Facts ).


stm_member( Term, stm(_,_,Facts) ) :-
    stm_member( Term, TimeStamp, stm(_,_,Facts) ).


show_stm( STM, Indent ) :-
    forall(
        stm_member( Term, TimeStamp, STM ),
        output( spaces_(Indent)<>Term...'('<>timestamp_(TimeStamp)<>')'~ )
    ).


list_to_stm( L, STM ) :-
    new_stm( STM0 ),
    list_to_stm( L, STM0, STM ).


list_to_stm( [], STM, STM ) :- !.

list_to_stm( [Term|Terms], STM0, STM ) :-
    stm_insert( STM0, 0, Term, STM1 ),
    list_to_stm( Terms, STM1, STM ).


/*
Output.
-------
*/


:- add_user_output( ps_output ).


ps_output( timestamp_(T) ) :-
    !,
    Time is T div 1000,
    Tag is T mod 1000,
    output( Time<>'.'<>Tag ).

ps_output( stm_(STM,Indent) ) :-
    !,
    show_stm(STM,Indent).

ps_output( rules_(Rules) ) :-
    !,
    output( Rules ).
    /* temp. */


:- endmodule.